diff --git a/hosts/javascript/platform.py b/hosts/javascript/platform.py index 5abc372f..a1102f6a 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; @@ -986,6 +1129,7 @@ PRIMITIVES_JS_MODULES: dict[str, str] = { PRIMITIVES["boolean?"] = function(x) { return x === true || x === false; }; PRIMITIVES["symbol?"] = function(x) { return x != null && x._sym === true; }; PRIMITIVES["keyword?"] = function(x) { return x != null && x._kw === true; }; + PRIMITIVES["adt?"] = function(x) { return x !== null && typeof x === "object" && x._adtv === true; }; PRIMITIVES["component-affinity"] = componentAffinity; ''', @@ -1004,12 +1148,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 +1435,65 @@ 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; }; + + // Short aliases — terser names; append accepts any value + PRIMITIVES["make-buffer"] = function() { return new SxStringBuffer(); }; + PRIMITIVES["buffer?"] = function(x) { return x instanceof SxStringBuffer; }; + PRIMITIVES["buffer-append!"] = function(buf, v) { + var s; + if (v === null || v === undefined || v === NIL) s = ""; + else if (typeof v === "string") s = v; + else if (typeof v === "boolean") s = v ? "true" : "false"; + else if (typeof v === "number") s = String(v); + else if (v && typeof v === "object" && typeof v.name === "string" && v.constructor && v.constructor.name === "Symbol") s = v.name; + else s = (typeof inspect === "function") ? inspect(v) : String(v); + buf.parts.push(s); buf.len += s.length; return NIL; + }; + PRIMITIVES["buffer->string"] = function(buf) { return buf.parts.join(""); }; + PRIMITIVES["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 +1604,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,12 +1940,40 @@ 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 (x._adtv) return x._type; if (typeof Node !== "undefined" && x instanceof Node) return "dom-node"; if (Array.isArray(x)) return "list"; if (typeof x === "object") return "dict"; return "unknown"; } + // AdtValue — native algebraic data type instance (Step 6 mirror of OCaml Step 5). + // Constructed by define-type. Carries _adt:true plus _adtv:true tag so type-of + // returns the type name rather than "dict". dict? remains true (shim approach) + // so spec-level match-pattern in evaluator.sx works without changes. + function makeAdtValue(typeName, ctorName, fields) { + return { + _adtv: true, + _adt: true, + _type: typeName, + _ctor: ctorName, + _fields: fields + }; + } + function isAdtValue(x) { + return x !== null && typeof x === "object" && x._adtv === true; + } + function symbolName(s) { return s.name; } function keywordName(k) { return k.name; } function makeSymbol(n) { return new Symbol(n); } @@ -1400,6 +2134,19 @@ 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)); } + + // hostWarn — emit a host-level warning to console (no-op if console missing). + function hostWarn(msg) { + var m = typeof msg === "string" ? msg : inspect(msg); + if (typeof console !== "undefined" && console.warn) console.warn(m); + return NIL; + } + // Render dispatch — call the active adapter's render function. // Set by each adapter when loaded; defaults to identity (no rendering). var _renderExprFn = null; @@ -1421,7 +2168,16 @@ PLATFORM_JS_PRE = ''' } function error(msg) { throw new Error(msg); } - function inspect(x) { return JSON.stringify(x); } + function inspect(x) { + if (x !== null && typeof x === "object" && x._adtv === true) { + var fs = x._fields || []; + if (fs.length === 0) return "(" + x._ctor + ")"; + var parts = []; + for (var i = 0; i < fs.length; i++) parts.push(inspect(fs[i])); + return "(" + x._ctor + " " + parts.join(" ") + ")"; + } + return JSON.stringify(x); + } function debugLog() { console.error.apply(console, ["[sx-debug]"].concat(Array.prototype.slice.call(arguments))); } ''' @@ -1485,12 +2241,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"]; @@ -1736,6 +2501,7 @@ CEK_FIXUPS_JS = ''' // Platform functions — defined in platform_js.py, not in .sx spec files. // Spec defines self-register via js-emit-define; these are the platform interface. PRIMITIVES["type-of"] = typeOf; + PRIMITIVES["inspect"] = inspect; PRIMITIVES["symbol-name"] = symbolName; PRIMITIVES["keyword-name"] = keywordName; PRIMITIVES["callable?"] = isCallable; @@ -1743,6 +2509,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 +2630,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 +2812,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); } @@ -2042,8 +2823,8 @@ PLATFORM_DOM_JS = """ // If lambda takes 0 params, call without event arg (convenience for on-click handlers) var wrapped = isLambda(handler) ? (lambdaParams(handler).length === 0 - ? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } } - : function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }) + ? function(e) { try { var r = cekCall(handler, NIL); if (globalThis._driveAsync) globalThis._driveAsync(r); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } } + : function(e) { try { var r = cekCall(handler, [e]); if (globalThis._driveAsync) globalThis._driveAsync(r); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }) : handler; if (name === "click") logInfo("domListen: click on <" + (el.tagName||"?").toLowerCase() + "> text=" + (el.textContent||"").substring(0,20) + " isLambda=" + isLambda(handler)); var passiveEvents = { touchstart: 1, touchmove: 1, wheel: 1, scroll: 1 }; @@ -2157,6 +2938,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 +3431,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 +3878,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 +4032,23 @@ 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["host-warn"] = function(msg) { + var m = typeof msg === "string" ? msg : inspect(msg); + if (typeof console !== "undefined" && console.warn) console.warn(m); + return NIL; + }; + 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 +4116,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; @@ -3348,7 +4160,56 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_ function clearStores() { _storeRegistry = {}; return NIL; } PRIMITIVES["def-store"] = defStore; PRIMITIVES["use-store"] = useStore; - PRIMITIVES["clear-stores"] = clearStores;'''] + PRIMITIVES["clear-stores"] = clearStores; + + // ----------------------------------------------------------------------- + // define-type override — produces native AdtValue instances (Step 6). + // The transpiled sfDefineType from evaluator.sx creates plain dict + // instances. We override here to construct AdtValue via makeAdtValue so + // type-of returns the type name and adt? can distinguish from dicts. + // dict? still returns true for AdtValue (shim) so spec-level match-pattern + // continues to work without changes. + // ----------------------------------------------------------------------- + var _sfDefineTypeAdt = function(args, env) { + var typeSym = first(args); + var ctorSpecs = rest(args); + var typeName = symbolName(typeSym); + var ctorNames = map(function(spec) { return symbolName(first(spec)); }, ctorSpecs); + if (!isSxTruthy(envHas(env, "*adt-registry*"))) { + envBind(env, "*adt-registry*", {}); + } + envGet(env, "*adt-registry*")[typeName] = ctorNames; + envBind(env, typeName + "?", function(v) { return isAdtValue(v) && v._type === typeName; }); + for (var _i = 0; _i < ctorSpecs.length; _i++) { + (function(spec) { + var cn = symbolName(first(spec)); + var fieldNames = map(function(f) { return symbolName(f); }, rest(spec)); + var arity = fieldNames.length; + envBind(env, cn, function() { + var ctorArgs = Array.prototype.slice.call(arguments, 0); + if (ctorArgs.length !== arity) { + throw new Error(cn + ": expected " + arity + " args, got " + ctorArgs.length); + } + return makeAdtValue(typeName, cn, ctorArgs); + }); + envBind(env, cn + "?", function(v) { return isAdtValue(v) && v._ctor === cn; }); + for (var _j = 0; _j < fieldNames.length; _j++) { + (function(idx, fieldName) { + envBind(env, cn + "-" + fieldName, function(v) { + if (!isAdtValue(v)) throw new Error(cn + "-" + fieldName + ": not an ADT"); + if (idx >= v._fields.length) throw new Error(cn + "-" + fieldName + ": index out of bounds"); + return v._fields[idx]; + }); + })(_j, fieldNames[_j]); + } + })(ctorSpecs[_i]); + } + return NIL; + }; + PRIMITIVES["sf-define-type"] = _sfDefineTypeAdt; + registerSpecialForm("define-type", _sfDefineTypeAdt); + PRIMITIVES["make-adt-value"] = makeAdtValue; + PRIMITIVES["adt-value?"] = isAdtValue;'''] if has_deps: lines.append(''' // Platform deps functions (native JS, not transpiled — need explicit registration) @@ -3493,35 +4354,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 +4390,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/bench_cek.ml b/hosts/ocaml/bin/bench_cek.ml new file mode 100644 index 00000000..f563afe3 --- /dev/null +++ b/hosts/ocaml/bin/bench_cek.ml @@ -0,0 +1,73 @@ +(** CEK benchmark — measures throughput of the CEK evaluator on tight loops. + + Usage: + dune exec bin/bench_cek.exe + dune exec bin/bench_cek.exe -- 5 (5 runs each) +*) + +open Sx_types +open Sx_parser + +let parse_one s = + let exprs = parse_all s in + match exprs with + | e :: _ -> e + | [] -> failwith "empty parse" + +let parse_many s = parse_all s + +let bench_run name setup expr iters = + let env = Sx_types.make_env () in + (* Run setup forms in env *) + List.iter (fun e -> ignore (Sx_ref.eval_expr e (Env env))) setup; + let times = ref [] in + for _ = 1 to iters do + Gc.full_major (); + let t0 = Unix.gettimeofday () in + let _r = Sx_ref.eval_expr expr (Env env) in + let t1 = Unix.gettimeofday () in + times := (t1 -. t0) :: !times + done; + let sorted = List.sort compare !times in + let median = List.nth sorted (iters / 2) in + let min_t = List.nth sorted 0 in + let max_t = List.nth sorted (iters - 1) in + Printf.printf " %-22s min=%8.2fms median=%8.2fms max=%8.2fms\n%!" + name (min_t *. 1000.0) (median *. 1000.0) (max_t *. 1000.0); + median + +let () = + let iters = + if Array.length Sys.argv > 1 + then int_of_string Sys.argv.(1) + else 5 + in + Printf.printf "CEK benchmark (%d runs each, taking median)\n%!" iters; + Printf.printf "==========================================\n%!"; + + (* fib 18 — recursive function call benchmark, smallish *) + let fib_setup = parse_many "(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))" in + let fib_expr = parse_one "(fib 18)" in + let _ = bench_run "fib(18)" fib_setup fib_expr iters in + + (* loop 5000 — tight let loop *) + let loop_setup = parse_many "(define (loop n acc) (if (= n 0) acc (loop (- n 1) (+ acc 1))))" in + let loop_expr = parse_one "(loop 5000 0)" in + let _ = bench_run "loop(5000)" loop_setup loop_expr iters in + + (* map+square over 1000 elem list *) + let map_setup = parse_many "(define (range-list n) (let loop ((i 0) (acc (list))) (if (= i n) acc (loop (+ i 1) (cons i acc))))) (define xs (range-list 1000))" in + let map_expr = parse_one "(map (fn (x) (* x x)) xs)" in + let _ = bench_run "map sq xs(1000)" map_setup map_expr iters in + + (* reduce + over 2000 elem list *) + let red_setup = parse_many "(define (range-list n) (let loop ((i 0) (acc (list))) (if (= i n) acc (loop (+ i 1) (cons i acc))))) (define ys (range-list 2000))" in + let red_expr = parse_one "(reduce + 0 ys)" in + let _ = bench_run "reduce + ys(2000)" red_setup red_expr iters in + + (* let-heavy: many bindings + if *) + let lh_setup = parse_many "(define (lh n) (let ((a 1) (b 2) (c 3) (d 4)) (if (= n 0) (+ a b c d) (lh (- n 1)))))" in + let lh_expr = parse_one "(lh 2000)" in + let _ = bench_run "let-heavy(2000)" lh_setup lh_expr iters in + + Printf.printf "\nDone.\n%!" diff --git a/hosts/ocaml/bin/bench_inspect.ml b/hosts/ocaml/bin/bench_inspect.ml new file mode 100644 index 00000000..ab9a3d6c --- /dev/null +++ b/hosts/ocaml/bin/bench_inspect.ml @@ -0,0 +1,46 @@ +(* Benchmark inspect on representative SX values. + Takes min of 9 runs of n iterations to dampen GC noise. *) +open Sx_types + +let rec make_tree d = + if d = 0 then String "leaf" + else List [String "node"; make_tree (d - 1); make_tree (d - 1); make_tree (d - 1)] + +let bench_min label f n runs = + let times = ref [] in + for _ = 1 to runs do + Gc.compact (); + let t0 = Unix.gettimeofday () in + for _ = 1 to n do ignore (f ()) done; + let t1 = Unix.gettimeofday () in + times := (t1 -. t0) :: !times + done; + let sorted = List.sort compare !times in + let min_t = List.nth sorted 0 in + let median = List.nth sorted (runs / 2) in + Printf.printf " %-30s min=%6.2fms median=%6.2fms (n=%d * %d runs)\n%!" + label (min_t *. 1000.0 /. float_of_int n) + (median *. 1000.0 /. float_of_int n) n runs + +let () = + let tree8 = make_tree 8 in + let s = inspect tree8 in + Printf.printf "tree-d8 inspect len=%d\n%!" (String.length s); + bench_min "inspect tree-d8" (fun () -> inspect tree8) 50 9; + + let tree10 = make_tree 10 in + let s = inspect tree10 in + Printf.printf "tree-d10 inspect len=%d\n%!" (String.length s); + bench_min "inspect tree-d10" (fun () -> inspect tree10) 5 9; + + let dict_xs = make_dict () in + for i = 0 to 999 do + Hashtbl.replace dict_xs (string_of_int i) (Integer i) + done; + let d = Dict dict_xs in + bench_min "inspect dict-1000" (fun () -> inspect d) 100 9; + + let xs = ref [] in + for i = 0 to 1999 do xs := Integer i :: !xs done; + let lst = List !xs in + bench_min "inspect list-2000" (fun () -> inspect lst) 200 9 diff --git a/hosts/ocaml/bin/bench_vm.ml b/hosts/ocaml/bin/bench_vm.ml new file mode 100644 index 00000000..0ff3d346 --- /dev/null +++ b/hosts/ocaml/bin/bench_vm.ml @@ -0,0 +1,155 @@ +(** VM bytecode benchmark — measures throughput of the VM (compiled bytecode). + + Loads the SX compiler via CEK, then for each test: + 1. Define the function via CEK (as a Lambda). + 2. Trigger JIT compilation via Sx_vm.jit_compile_lambda. + 3. Call the compiled VmClosure repeatedly via Sx_vm.call_closure. + + This measures pure VM execution time on the JIT path. *) + +open Sx_types + +let load_compiler env globals = + let compiler_path = + if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx" + else if Sys.file_exists "../../lib/compiler.sx" then "../../lib/compiler.sx" + else if Sys.file_exists "../../../lib/compiler.sx" then "../../../lib/compiler.sx" + else failwith "compiler.sx not found" + in + let ic = open_in compiler_path in + let src = really_input_string ic (in_channel_length ic) in + close_in ic; + let exprs = Sx_parser.parse_all src in + List.iter (fun e -> ignore (Sx_ref.eval_expr e (Env env))) exprs; + let rec sync e = + Hashtbl.iter (fun id v -> + let name = Sx_types.unintern id in + Hashtbl.replace globals name v) e.bindings; + match e.parent with Some p -> sync p | None -> () + in + sync env + +let _make_globals env = + let g = Hashtbl.create 512 in + Hashtbl.iter (fun name fn -> + Hashtbl.replace g name (NativeFn (name, fn)) + ) Sx_primitives.primitives; + let rec sync e = + Hashtbl.iter (fun id v -> + let name = Sx_types.unintern id in + if not (Hashtbl.mem g name) then Hashtbl.replace g name v) e.bindings; + match e.parent with Some p -> sync p | None -> () + in + sync env; + g + +let define_fn env globals name params body_src = + (* Define via CEK so we get a Lambda value with proper closure. *) + let body_expr = match Sx_parser.parse_all body_src with + | [e] -> e + | _ -> failwith "expected one body expression" + in + let param_syms = List (List.map (fun p -> Symbol p) params) in + let define_expr = List [Symbol "define"; Symbol name; List [Symbol "fn"; param_syms; body_expr]] in + ignore (Sx_ref.eval_expr define_expr (Env env)); + (* Sync env to globals so JIT can resolve free vars. *) + let rec sync e = + Hashtbl.iter (fun id v -> + let n = Sx_types.unintern id in + Hashtbl.replace globals n v) e.bindings; + match e.parent with Some p -> sync p | None -> () + in + sync env; + (* Now find the Lambda and JIT-compile it. *) + let lam_val = Hashtbl.find globals name in + match lam_val with + | Lambda l -> + (match Sx_vm.jit_compile_lambda l globals with + | Some cl -> + l.l_compiled <- Some cl; + Hashtbl.replace globals name (NativeFn (name, fun args -> + Sx_vm.call_closure cl args globals)); + cl + | None -> + failwith (Printf.sprintf "JIT failed for %s" name)) + | _ -> failwith (Printf.sprintf "%s is not a Lambda after define" name) + +let bench_call name cl globals args iters = + let times = ref [] in + for _ = 1 to iters do + Gc.full_major (); + let t0 = Unix.gettimeofday () in + let _r = Sx_vm.call_closure cl args globals in + let t1 = Unix.gettimeofday () in + times := (t1 -. t0) :: !times + done; + let sorted = List.sort compare !times in + let median = List.nth sorted (iters / 2) in + let min_t = List.nth sorted 0 in + let max_t = List.nth sorted (iters - 1) in + Printf.printf " %-22s min=%8.2fms median=%8.2fms max=%8.2fms\n%!" + name (min_t *. 1000.0) (median *. 1000.0) (max_t *. 1000.0); + median + +let () = + let iters = + if Array.length Sys.argv > 1 + then int_of_string Sys.argv.(1) + else 7 + in + Printf.printf "VM (bytecode/JIT) benchmark (%d runs each, taking median)\n%!" iters; + Printf.printf "========================================================\n%!"; + + let env = Sx_types.make_env () in + let bind n fn = ignore (Sx_types.env_bind env n (NativeFn (n, fn))) in + (* Seed env with primitives as NativeFn so CEK lookups work. *) + Hashtbl.iter (fun name fn -> + Hashtbl.replace env.bindings (Sx_types.intern name) (NativeFn (name, fn)) + ) Sx_primitives.primitives; + (* Helpers the SX compiler relies on but aren't kernel primitives. *) + bind "symbol-name" (fun args -> match args with + | [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name")); + bind "keyword-name" (fun args -> match args with + | [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name")); + bind "make-symbol" (fun args -> match args with + | [String s] -> Symbol s + | [v] -> Symbol (Sx_types.value_to_string v) + | _ -> raise (Eval_error "make-symbol")); + bind "sx-serialize" (fun args -> match args with + | [v] -> String (Sx_types.inspect v) + | _ -> raise (Eval_error "sx-serialize")); + let globals = Hashtbl.create 1024 in + Hashtbl.iter (fun name fn -> + Hashtbl.replace globals name (NativeFn (name, fn)) + ) Sx_primitives.primitives; + Printf.printf "Loading compiler.sx ... %!"; + let t0 = Unix.gettimeofday () in + load_compiler env globals; + Printf.printf "%.0fms\n%!" ((Unix.gettimeofday () -. t0) *. 1000.0); + + (* fib(22) — recursive call benchmark *) + let fib_cl = define_fn env globals "fib" ["n"] + "(if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))" in + let _ = bench_call "fib(22)" fib_cl globals [Number 22.0] iters in + + (* tight loop *) + let loop_cl = define_fn env globals "loop" ["n"; "acc"] + "(if (= n 0) acc (loop (- n 1) (+ acc 1)))" in + let _ = bench_call "loop(200000)" loop_cl globals [Number 200000.0; Number 0.0] iters in + + (* sum-to *) + let sum_cl = define_fn env globals "sum_to" ["n"; "acc"] + "(if (= n 0) acc (sum_to (- n 1) (+ acc n)))" in + let _ = bench_call "sum-to(50000)" sum_cl globals [Number 50000.0; Number 0.0] iters in + + (* count-lt: comparison-heavy *) + let cnt_cl = define_fn env globals "count_lt" ["n"; "acc"] + "(if (= n 0) acc (count_lt (- n 1) (if (< n 10000) (+ acc 1) acc)))" in + let _ = bench_call "count-lt(20000)" cnt_cl globals [Number 20000.0; Number 0.0] iters in + + (* count-eq: equality-heavy on multiples of 7 *) + let eq_cl = define_fn env globals "count_eq" ["n"; "acc"] + "(if (= n 0) acc (count_eq (- n 1) (if (= 0 (- n (* 7 (/ n 7)))) (+ acc 1) acc)))" in + let _ = bench_call "count-eq(20000)" eq_cl globals [Number 20000.0; Number 0.0] iters in + + Printf.printf "\nDone.\n%!" diff --git a/hosts/ocaml/bin/dune b/hosts/ocaml/bin/dune index 892f99b7..1d892dd4 100644 --- a/hosts/ocaml/bin/dune +++ b/hosts/ocaml/bin/dune @@ -1,5 +1,5 @@ (executables - (names run_tests debug_set sx_server integration_tests) + (names run_tests debug_set sx_server integration_tests bench_cek bench_inspect bench_vm) (libraries sx unix threads.posix otfm yojson)) (executable diff --git a/hosts/ocaml/bin/mcp_tree.ml b/hosts/ocaml/bin/mcp_tree.ml index ebcb1f50..8591d00a 100644 --- a/hosts/ocaml/bin/mcp_tree.ml +++ b/hosts/ocaml/bin/mcp_tree.ml @@ -1892,8 +1892,34 @@ let handle_sx_harness_eval args = let file = args |> member "file" |> to_string_option in let setup_str = args |> member "setup" |> to_string_option in let files_json = try args |> member "files" with _ -> `Null in + let host_stubs = match args |> member "host_stubs" with `Bool b -> b | _ -> false in let e = !env in let warnings = ref [] in + (* Inject stub host primitives so files using host-get/host-new/etc. can load *) + if host_stubs then begin + let stubs = {| + (define host-global (fn (&rest _) nil)) + (define host-get (fn (&rest _) nil)) + (define host-set! (fn (obj k v) v)) + (define host-call (fn (&rest _) nil)) + (define host-new (fn (&rest _) (dict))) + (define host-callback (fn (f) f)) + (define host-typeof (fn (&rest _) "string")) + (define hs-ref-eq (fn (a b) (identical? a b))) + (define host-call-fn (fn (&rest _) nil)) + (define host-iter? (fn (&rest _) false)) + (define host-to-list (fn (&rest _) (list))) + (define host-await (fn (&rest _) nil)) + (define host-new-function (fn (&rest _) nil)) + (define load-library! (fn (&rest _) false)) + |} in + let stub_exprs = Sx_parser.parse_all stubs in + List.iter (fun expr -> + try ignore (Sx_ref.eval_expr expr (Env e)) + with exn -> + warnings := Printf.sprintf "Stub warning: %s" (Printexc.to_string exn) :: !warnings + ) stub_exprs + end; (* Collect all files to load *) let all_files = match files_json with | `List items -> @@ -3018,7 +3044,8 @@ let tool_definitions = `List [ ("mock", `Assoc [("type", `String "string"); ("description", `String "Optional mock platform overrides as SX dict, e.g. {:fetch (fn (url) {:status 200})}")]); ("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")]); ("files", `Assoc [("type", `String "array"); ("items", `Assoc [("type", `String "string")]); ("description", `String "Multiple .sx files to load in order")]); - ("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")])] + ("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")]); + ("host_stubs", `Assoc [("type", `String "boolean"); ("description", `String "If true, inject nil-returning stubs for host-get/host-set!/host-call/host-new/etc. so files that use host primitives can load in the harness")])] ["expr"]; tool "sx_nav" "Manage sx-docs navigation and articles. Modes: list (all nav items with status), check (validate consistency), add (create article + nav entry), delete (remove nav entry + page fn), move (move entry between sections, rewriting hrefs)." [("mode", `Assoc [("type", `String "string"); ("description", `String "Mode: list, check, add, delete, or move")]); diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 823df835..17e35393 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; @@ -2837,6 +2899,9 @@ let run_spec_tests env test_files = load_module "parser.sx" hs_dir; load_module "compiler.sx" hs_dir; load_module "runtime.sx" hs_dir; + let hs_plugins_dir = Filename.concat hs_dir "plugins" in + load_module "worker.sx" hs_plugins_dir; + load_module "prolog.sx" hs_plugins_dir; load_module "integration.sx" hs_dir; load_module "htmx.sx" hs_dir; (* Override console-log to avoid str on circular mock DOM refs *) diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index a14d9e25..40de7b49 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 @@ -688,6 +703,11 @@ let setup_evaluator_bridge env = | [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e)) | [expr] -> Sx_ref.eval_expr expr (Env env) | _ -> raise (Eval_error "eval-expr: expected (expr env?)")); + (* eval-in-env: (env expr) → result. Evaluates expr in the given env. *) + Sx_primitives.register "eval-in-env" (fun args -> + match args with + | [e; expr] -> Sx_ref.eval_expr expr e + | _ -> raise (Eval_error "eval-in-env: (env expr)")); bind "trampoline" (fun args -> match args with | [v] -> @@ -749,7 +769,13 @@ let setup_evaluator_bridge env = | _ -> raise (Eval_error "register-special-form!: expected (name handler)")); ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms); ignore (Sx_ref.register_special_form (String "<>") (NativeFn ("<>", fun args -> - List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args)))) + List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args)))); + (* current-env: special form — returns current lexical env as a first-class value *) + ignore (Sx_ref.register_special_form (String "current-env") + (NativeFn ("current-env", fun args -> + match args with + | [_arg_list; env_val] -> env_val + | _ -> Nil))) (* ---- Type predicates and introspection ---- *) let setup_introspection env = @@ -935,7 +961,24 @@ let setup_env_operations env = bind "env-has?" (fun args -> match args with [e; String k] -> Bool (Sx_types.env_has (uw e) k) | [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k) | _ -> raise (Eval_error "env-has?: expected env and string")); bind "env-bind!" (fun args -> match args with [e; String k; v] -> Sx_types.env_bind (uw e) k v | [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v | _ -> raise (Eval_error "env-bind!: expected env, key, value")); bind "env-set!" (fun args -> match args with [e; String k; v] -> Sx_types.env_set (uw e) k v | [e; Keyword k; v] -> Sx_types.env_set (uw e) k v | _ -> raise (Eval_error "env-set!: expected env, key, value")); - bind "env-extend" (fun args -> match args with [e] -> Env (Sx_types.env_extend (uw e)) | _ -> raise (Eval_error "env-extend: expected env")); + bind "env-extend" (fun args -> + match args with + | e :: pairs -> + let child = Sx_types.env_extend (uw e) in + let rec go = function + | [] -> () + | k :: v :: rest -> + ignore (Sx_types.env_bind child (Sx_runtime.value_to_str k) v); go rest + | [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in + go pairs; Env child + | _ -> raise (Eval_error "env-extend: expected env")); + bind "env-lookup" (fun args -> + match args with + | [e; key] -> + let k = Sx_runtime.value_to_str key in + let raw = uw e in + if Sx_types.env_has raw k then Sx_types.env_get raw k else Nil + | _ -> raise (Eval_error "env-lookup: (env key)")); bind "env-merge" (fun args -> match args with [a; b] -> Sx_runtime.env_merge a b | _ -> raise (Eval_error "env-merge: expected 2 envs")) (* ---- Strict mode (gradual type system support) ---- *) @@ -959,6 +1002,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 +1405,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 +1419,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 +4499,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 +4558,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..e8df8b4e 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) @@ -80,7 +82,10 @@ let cek_run_iterative state = s := cek_step !s done; (match cek_suspended_p !s with - | Bool true -> raise (Eval_error "IO suspension in non-IO context") + | Bool true -> + (match !_cek_io_suspend_hook with + | Some hook -> hook !s + | None -> raise (Eval_error "IO suspension in non-IO context")) | _ -> cek_value !s) with Eval_error msg -> _last_error_kont_ref := cek_kont !s; @@ -126,6 +131,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 +260,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) @@ -219,6 +311,23 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str: output ) + # Patch transpiled cek_run to invoke _cek_io_suspend_hook on suspension + # instead of unconditionally raising Eval_error. This is the fix for the + # tree-walk eval_expr path: sf_letrec init exprs / non-last body exprs, + # macro bodies, qq_expand, dynamic-wind / scope / provide bodies all use + # `trampoline (eval_expr ...)` and were swallowing CEK suspensions as + # "IO suspension in non-IO context" errors. With the hook, the suspension + # propagates as VmSuspended to the outer driver (browser callFn / server + # eval_expr_io). When the hook is unset (pure-CEK harness), the legacy + # error is preserved as the fallback. + output = re.sub( + r'\(raise \(Eval_error \(value_to_str \(String "IO suspension in non-IO context"\)\)\)\)', + '(match !_cek_io_suspend_hook with Some hook -> hook final | None -> ' + '(raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))))', + output, + count=1, + ) + return output diff --git a/hosts/ocaml/bootstrap_vm.py b/hosts/ocaml/bootstrap_vm.py index 4b4c8c34..5d2f461b 100644 --- a/hosts/ocaml/bootstrap_vm.py +++ b/hosts/ocaml/bootstrap_vm.py @@ -355,7 +355,9 @@ let vm_create_closure vm_val frame_val code_val = let f = unwrap_frame frame_val in let uv_count = match code_val with | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with - | Some (Number n) -> int_of_float n | _ -> 0) + | Some (Integer n) -> n + | Some (Number n) -> int_of_float n + | _ -> 0) | _ -> 0 in let upvalues = Array.init uv_count (fun _ -> diff --git a/hosts/ocaml/browser/bundle.sh b/hosts/ocaml/browser/bundle.sh index 2b82e803..5e833b20 100755 --- a/hosts/ocaml/browser/bundle.sh +++ b/hosts/ocaml/browser/bundle.sh @@ -75,6 +75,9 @@ cp "$ROOT/shared/sx/templates/tw.sx" "$DIST/sx/" for f in tokenizer parser compiler runtime integration htmx; do cp "$ROOT/lib/hyperscript/$f.sx" "$DIST/sx/hs-$f.sx" done +for f in worker prolog; do + cp "$ROOT/lib/hyperscript/plugins/$f.sx" "$DIST/sx/hs-$f.sx" +done # Summary WASM_SIZE=$(du -sh "$DIST/sx_browser.bc.wasm.assets" | cut -f1) diff --git a/hosts/ocaml/browser/compile-modules.js b/hosts/ocaml/browser/compile-modules.js index 55ebc1e0..11c64058 100644 --- a/hosts/ocaml/browser/compile-modules.js +++ b/hosts/ocaml/browser/compile-modules.js @@ -85,6 +85,7 @@ const FILES = [ 'harness-web.sx', 'engine.sx', 'orchestration.sx', // Hyperscript modules — loaded on demand via transparent lazy loader 'hs-tokenizer.sx', 'hs-parser.sx', 'hs-compiler.sx', 'hs-runtime.sx', + 'hs-worker.sx', 'hs-prolog.sx', 'hs-integration.sx', 'hs-htmx.sx', 'boot.sx', ]; @@ -455,8 +456,10 @@ for (const file of FILES) { 'hs-parser': ['hs-tokenizer'], 'hs-compiler': ['hs-tokenizer', 'hs-parser'], 'hs-runtime': ['hs-tokenizer', 'hs-parser', 'hs-compiler'], - 'hs-integration': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'], - 'hs-htmx': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration'], + 'hs-worker': ['hs-tokenizer', 'hs-parser'], + 'hs-prolog': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'], + 'hs-integration': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-worker', 'hs-prolog'], + 'hs-htmx': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-worker', 'hs-prolog', 'hs-integration'], }; manifest[key] = { file: sxbcFile, @@ -477,7 +480,7 @@ if (entryFile) { const lazyDeps = entryFile.deps.filter(d => LAZY_ENTRY_DEPS.has(d)); // Hyperscript modules aren't define-library, so not auto-detected as deps. // Load them lazily after boot — eager loading breaks the boot sequence. - const HS_LAZY = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration', 'hs-htmx']; + const HS_LAZY = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-worker', 'hs-prolog', 'hs-integration', 'hs-htmx']; for (const m of HS_LAZY) { if (manifest[m] && !lazyDeps.includes(m)) lazyDeps.push(m); } diff --git a/hosts/ocaml/browser/sx_browser.ml b/hosts/ocaml/browser/sx_browser.ml index c61cac7f..60511546 100644 --- a/hosts/ocaml/browser/sx_browser.ml +++ b/hosts/ocaml/browser/sx_browser.ml @@ -344,6 +344,12 @@ let api_eval src_js = sync_env_to_vm (); return_via_side_channel (value_to_js result) with + | Sx_vm.VmSuspended _ -> + (* Top-level eval encountered an IO suspension propagated via the + cek_run hook (perform inside letrec init / non-last body / macro / + qq tree-walked path). K.eval doesn't drive resumption — surface as + a clear error so the caller knows to use callFn instead. *) + Js.Unsafe.inject (Js.string "Error: IO suspension in non-IO context (use callFn for IO-aware paths)") | Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg)) | Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg)) @@ -371,6 +377,8 @@ let api_eval_vm src_js = ) _vm_globals; return_via_side_channel (value_to_js result) with + | Sx_vm.VmSuspended _ -> + Js.Unsafe.inject (Js.string "Error: IO suspension in non-IO context (use callFn for IO-aware paths)") | Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg)) | Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg)) | Not_found -> Js.Unsafe.inject (Js.string "Error: compile-module not loaded") @@ -381,7 +389,10 @@ let api_eval_expr expr_js _env_js = let result = Sx_ref.eval_expr expr (Env global_env) in sync_env_to_vm (); return_via_side_channel (value_to_js result) - with Eval_error msg -> + with + | Sx_vm.VmSuspended _ -> + Js.Unsafe.inject (Js.string "Error: IO suspension in non-IO context (use callFn for IO-aware paths)") + | Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg)) let api_load src_js = @@ -704,8 +715,10 @@ let () = | List (Symbol "code" :: rest) -> let d = Hashtbl.create 8 in let rec parse_kv = function - | Keyword "arity" :: Number n :: rest -> Hashtbl.replace d "arity" (Number n); parse_kv rest - | Keyword "upvalue-count" :: Number n :: rest -> Hashtbl.replace d "upvalue-count" (Number n); parse_kv rest + | Keyword "arity" :: (Number _ as n) :: rest -> Hashtbl.replace d "arity" n; parse_kv rest + | Keyword "arity" :: (Integer _ as n) :: rest -> Hashtbl.replace d "arity" n; parse_kv rest + | Keyword "upvalue-count" :: (Number _ as n) :: rest -> Hashtbl.replace d "upvalue-count" n; parse_kv rest + | Keyword "upvalue-count" :: (Integer _ as n) :: rest -> Hashtbl.replace d "upvalue-count" n; parse_kv rest | Keyword "bytecode" :: List nums :: rest -> Hashtbl.replace d "bytecode" (List nums); parse_kv rest | Keyword "constants" :: List consts :: rest -> diff --git a/hosts/ocaml/browser/test_letrec_resume.js b/hosts/ocaml/browser/test_letrec_resume.js new file mode 100644 index 00000000..550355cf --- /dev/null +++ b/hosts/ocaml/browser/test_letrec_resume.js @@ -0,0 +1,172 @@ +#!/usr/bin/env node +// Repro: letrec sibling bindings nil after perform/resume in browser kernel +// +// Bug: After a CEK IO suspension (perform / hs-wait) resumes in the +// WASM browser kernel, calling a sibling letrec binding could return +// nil, with the error surfaced as `[sx] resume: Not callable: nil`. +// +// Root cause: cek-run / cek_run_iterative raised +// `"IO suspension in non-IO context"` when a tree-walked eval_expr +// (sf_letrec init exprs / non-last body, macro body, qq unquote, scope +// body, provide body, dynamic-wind) hit a perform. The CEK suspension +// was created correctly but never propagated through the OCaml-side +// _cek_io_suspend_hook, so the outer driver never saw VmSuspended. +// +// Fix: cek_run / cek_run_iterative now invoke _cek_io_suspend_hook on +// suspension (raising VmSuspended for the outer driver). When the hook +// is unset (pure-CEK harness), they fall back to the legacy error. +// +// This test exercises the WASM kernel through K.callFn — the path that +// browser event handlers use. Suspension surfaces as a JS object with +// {suspended, request, resume(result)} that the test drives synchronously. +// +// Companion: spec/tests/test-letrec-resume-treewalk.sx tests the +// CEK-only path through the OCaml test runner. + +const path = require('path'); +const fs = require('fs'); + +const KERNEL = path.join(__dirname, '..', '_build', 'default', 'browser', 'sx_browser.bc.js'); +if (!fs.existsSync(KERNEL)) { + console.error('FATAL: missing ' + KERNEL + ' — run `dune build` from hosts/ocaml first'); + process.exit(2); +} +require(KERNEL); +const K = globalThis.SxKernel; + +let passed = 0, failed = 0; +const failures = []; + +function test(name, fn) { + try { + const r = fn(); + if (r === true) { + passed++; + console.log(' PASS: ' + name); + } else { + failed++; + failures.push({ name, error: 'got ' + JSON.stringify(r) }); + console.log(' FAIL: ' + name + ' — got ' + JSON.stringify(r)); + } + } catch (e) { + failed++; + failures.push({ name, error: e.message || String(e) }); + console.log(' FAIL: ' + name + ' — ' + (e.message || e)); + } +} + +function driveSync(result) { + while (result && typeof result === 'object' && result.suspended) { + result = result.resume(null); + } + return result; +} + +function callExpr(src) { + K.eval('(define _t-fn (fn () ' + src + '))'); + const fn = K.eval('_t-fn'); + return driveSync(K.callFn(fn, [])); +} + +console.log('\n=== letrec + perform/resume regression tests ===\n'); + +test('basic letrec without perform', () => + callExpr('(letrec ((f (fn () "ok"))) (f))') === 'ok'); + +test('callFn perform suspends and resumes with nil', () => { + K.eval('(define _t-perform (fn () (perform {:op "io"})))'); + let r = K.callFn(K.eval('_t-perform'), []); + if (!r || !r.suspended) return 'no suspension: ' + JSON.stringify(r); + return r.resume(null) === null; +}); + +test('letrec, single binding, perform/resume', () => + callExpr('(letrec ((f (fn () (perform {:op "io"})))) (f))') === null); + +test('letrec, 2 bindings, body calls sibling after suspended call', () => + callExpr(` + (letrec + ((wait-then (fn () (do (perform {:op "io"}) "wait-done"))) + (other-fn (fn () "other-result"))) + (do (wait-then) (other-fn)))`) === 'other-result'); + +test('letrec, suspending fn calls sibling after own perform', () => + callExpr(` + (letrec + ((wait-and-call (fn () (do (perform {:op "io"}) (other-fn)))) + (other-fn (fn () "from-sibling"))) + (wait-and-call))`) === 'from-sibling'); + +test('letrec, fn references sibling value after perform/resume', () => + callExpr(` + (letrec + ((shared "shared-state") + (do-fn (fn () (do (perform {:op "io"}) shared)))) + (do-fn))`) === 'shared-state'); + +test('letrec, recursive self-call after perform (wait-boot pattern)', () => { + K.eval('(define _wb-c 0)'); + K.eval('(set! _wb-c 0)'); + return callExpr(` + (letrec ((wait-boot (fn () + (do (perform {:op "io"}) + (if (>= _wb-c 1) + "done" + (do (set! _wb-c (+ 1 _wb-c)) + (wait-boot))))))) + (wait-boot))`) === 'done'; +}); + +test('top-level define + perform + sibling call after resume', () => { + K.eval('(define do-suspend-x (fn () (do (perform {:op "io"}) (do-other-x))))'); + K.eval('(define do-other-x (fn () "ok-from-other"))'); + return callExpr('(do-suspend-x)') === 'ok-from-other'; +}); + +test('letrec, two performs (sequential) then sibling call', () => + callExpr(` + (letrec + ((wait-twice (fn () (do (perform {:op "io1"}) (perform {:op "io2"}) (other)))) + (other (fn () "after-double"))) + (wait-twice))`) === 'after-double'); + +// === Tree-walk paths that previously raised "IO suspension in non-IO context" === + +test('letrec init expr with perform — suspension propagates (no error)', () => { + let r; + try { r = callExpr('(letrec ((x (perform {:op "io"}))) "ok")'); } + catch (e) { return 'threw: ' + e.message; } + return r === null || r === 'ok'; +}); + +test('letrec non-last body with perform — suspension propagates (no error)', () => { + let r; + try { r = callExpr('(letrec ((x 1)) (perform {:op "io"}) "after")'); } + catch (e) { return 'threw: ' + e.message; } + return r === null || r === 'after'; +}); + +test('macro body with perform — suspension propagates', () => { + K.eval('(defmacro _m1 (form) (do (perform {:op "io"}) form))'); + let r; + try { r = callExpr('(_m1 "macro-ok")'); } + catch (e) { return 'threw: ' + e.message; } + return r === 'macro-ok' || r === null; +}); + +test('quasiquote unquote with perform — suspension propagates', () => { + let r; + try { r = callExpr('(let ((y "yyy")) `(a ,(do (perform {:op "io"}) y) c))'); } + catch (e) { return 'threw: ' + e.message; } + return r !== undefined; +}); + +console.log('\n--- Results ---'); +console.log('passed: ' + passed); +console.log('failed: ' + failed); +if (failed > 0) { + console.log('\nFailures:'); + failures.forEach(f => console.log(' - ' + f.name + ': ' + f.error)); + process.exit(1); +} +process.exit(0); diff --git a/hosts/ocaml/lib/dune b/hosts/ocaml/lib/dune index 4dd17fc1..0a5bf1a7 100644 --- a/hosts/ocaml/lib/dune +++ b/hosts/ocaml/lib/dune @@ -1,4 +1,4 @@ (library (name sx) (wrapped false) - (libraries re re.pcre)) + (libraries re re.pcre unix)) diff --git a/hosts/ocaml/lib/sx_compiler.ml b/hosts/ocaml/lib/sx_compiler.ml index 0e8a007c..53b7a8ff 100644 --- a/hosts/ocaml/lib/sx_compiler.ml +++ b/hosts/ocaml/lib/sx_compiler.ml @@ -200,7 +200,30 @@ and compile_qq_list em items scope = (* compile-call *) and compile_call em head args scope tail_p = - (let is_prim = (let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let name = (symbol_name (head)) in (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "local")]))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "upvalue")]))))) in if not (sx_truthy _and) then _and else (is_primitive (name)))))) in (if sx_truthy (is_prim) then (let name = (symbol_name (head)) in let argc = (len (args)) in let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (name_idx))) in (emit_byte (em) (argc)))))) else (let () = ignore ((compile_expr (em) (head) (scope) ((Bool false)))) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (if sx_truthy (tail_p) then (let () = ignore ((emit_op (em) ((Number 49.0)))) in (emit_byte (em) ((len (args))))) else (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((len (args)))))))))) + (let is_prim = (let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let name = (symbol_name (head)) in (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "local")]))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "upvalue")]))))) in if not (sx_truthy _and) then _and else (is_primitive (name)))))) in (if sx_truthy (is_prim) then (let name = (symbol_name (head)) in let argc = (len (args)) in + (* Specialized opcode for hot 2-arg / 1-arg primitives. *) + let specialized_op = (match name, argc with + | String "+", Number 2.0 -> Some 160 + | String "-", Number 2.0 -> Some 161 + | String "*", Number 2.0 -> Some 162 + | String "/", Number 2.0 -> Some 163 + | String "=", Number 2.0 -> Some 164 + | String "<", Number 2.0 -> Some 165 + | String ">", Number 2.0 -> Some 166 + | String "cons", Number 2.0 -> Some 172 + | String "not", Number 1.0 -> Some 167 + | String "len", Number 1.0 -> Some 168 + | String "first", Number 1.0 -> Some 169 + | String "rest", Number 1.0 -> Some 170 + | _ -> None) in + (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in + (match specialized_op with + | Some op -> emit_op em (Number (float_of_int op)) + | None -> + let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in + let () = ignore ((emit_op (em) ((Number 52.0)))) in + let () = ignore ((emit_u16 (em) (name_idx))) in + emit_byte (em) (argc)))) else (let () = ignore ((compile_expr (em) (head) (scope) ((Bool false)))) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (if sx_truthy (tail_p) then (let () = ignore ((emit_op (em) ((Number 49.0)))) in (emit_byte (em) ((len (args))))) else (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((len (args)))))))))) (* compile *) and compile expr = 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..0ed7b8cf 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 -> @@ -378,7 +666,9 @@ let () = register "list?" (fun args -> match args with [List _] | [ListRef _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "list?: 1 arg")); register "dict?" (fun args -> - match args with [Dict _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg")); + match args with [Dict _] -> Bool true | [AdtValue _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg")); + register "adt?" (fun args -> + match args with [AdtValue _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "adt?: 1 arg")); register "symbol?" (fun args -> match args with [Symbol _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "symbol?: 1 arg")); register "keyword?" (fun args -> @@ -412,7 +702,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 +736,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 +751,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 +791,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 +818,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 +923,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 +960,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 +1009,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 +1034,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 +1082,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 +1115,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 +1172,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 +1215,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 @@ -963,6 +1281,11 @@ let () = match args with [String msg] -> raise (Eval_error msg) | [a] -> raise (Eval_error (to_string a)) | _ -> raise (Eval_error "host-error: 1 arg")); + register "host-warn" (fun args -> + match args with + | [String msg] -> prerr_endline msg; Nil + | [a] -> prerr_endline (to_string a); Nil + | _ -> raise (Eval_error "host-warn: 1 arg")); register "try-catch" (fun args -> match args with | [try_fn; catch_fn] -> @@ -1025,15 +1348,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 +1394,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 +1437,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 +1538,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 +1577,61 @@ 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)")); + + (* Short aliases — same StringBuffer value, terser names for hot paths. + Append accepts any value: strings pass through, others get inspected/coerced. *) + register "make-buffer" (fun _ -> StringBuffer (Buffer.create 64)); + register "buffer?" (fun args -> + match args with [StringBuffer _] -> Bool true | [_] -> Bool false + | _ -> raise (Eval_error "buffer?: expected 1 arg")); + register "buffer-append!" (fun args -> + match args with + | [StringBuffer buf; String s] -> Buffer.add_string buf s; Nil + | [StringBuffer buf; Integer n] -> Buffer.add_string buf (string_of_int n); Nil + | [StringBuffer buf; Number n] -> Buffer.add_string buf (Sx_types.format_number n); Nil + | [StringBuffer buf; Symbol s] -> Buffer.add_string buf s; Nil + | [StringBuffer buf; Char n] -> + Buffer.add_utf_8_uchar buf (Uchar.of_int n); Nil + | [StringBuffer buf; Nil] -> Buffer.add_string buf ""; Nil + | [StringBuffer buf; Bool true] -> Buffer.add_string buf "true"; Nil + | [StringBuffer buf; Bool false] -> Buffer.add_string buf "false"; Nil + | [StringBuffer buf; v] -> Buffer.add_string buf (inspect v); Nil + | _ -> raise (Eval_error "buffer-append!: expected (buffer value)")); + register "buffer->string" (fun args -> + match args with [StringBuffer buf] -> String (Buffer.contents buf) + | _ -> raise (Eval_error "buffer->string: expected (buffer)")); + register "buffer-length" (fun args -> + match args with [StringBuffer buf] -> Integer (Buffer.length buf) + | _ -> raise (Eval_error "buffer-length: expected (buffer)")); (* Capability-based sandboxing — gate IO operations *) let cap_stack : string list ref = ref [] in @@ -1871,4 +2255,1483 @@ 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")); + + (* === File I/O === *) + register "file-read" (fun args -> + match args with + | [String path] -> + (try + let ic = open_in path in + let n = in_channel_length ic in + let s = Bytes.create n in + really_input ic s 0 n; + close_in ic; + String (Bytes.to_string s) + with Sys_error msg -> raise (Eval_error ("file-read: " ^ msg))) + | _ -> raise (Eval_error "file-read: (path)")); + + register "file-write" (fun args -> + match args with + | [String path; String content] -> + (try + let oc = open_out path in + output_string oc content; + close_out oc; + Nil + with Sys_error msg -> raise (Eval_error ("file-write: " ^ msg))) + | _ -> raise (Eval_error "file-write: (path content)")); + + register "file-append" (fun args -> + match args with + | [String path; String content] -> + (try + let oc = open_out_gen [Open_append; Open_creat; Open_wronly; Open_text] 0o644 path in + output_string oc content; + close_out oc; + Nil + with Sys_error msg -> raise (Eval_error ("file-append: " ^ msg))) + | _ -> raise (Eval_error "file-append: (path content)")); + + register "file-exists?" (fun args -> + match args with + | [String path] -> Bool (Sys.file_exists path) + | _ -> raise (Eval_error "file-exists?: (path)")); + + register "file-glob" (fun args -> + let glob_match pat str = + let pn = String.length pat and sn = String.length str in + let rec go pi si = + if pi = pn then si = sn + else match pat.[pi] with + | '*' -> + let rec try_from i = i <= sn && (go (pi+1) i || try_from (i+1)) in + try_from si + | '?' -> si < sn && go (pi+1) (si+1) + | '[' -> + let pi' = ref (pi+1) in + let negate = !pi' < pn && pat.[!pi'] = '^' in + if negate then incr pi'; + let matched = ref false in + while !pi' < pn && pat.[!pi'] <> ']' do + let c1 = pat.[!pi'] in + incr pi'; + if !pi' + 1 < pn && pat.[!pi'] = '-' then begin + let c2 = pat.[!pi' + 1] in + pi' := !pi' + 2; + if si < sn && str.[si] >= c1 && str.[si] <= c2 then matched := true + end else if si < sn && str.[si] = c1 then matched := true + done; + if !pi' < pn then incr pi'; + ((!matched && not negate) || (not !matched && negate)) && go !pi' (si+1) + | c -> si < sn && str.[si] = c && go (pi+1) (si+1) + in go 0 0 + in + let glob_paths pat = + let dir = Filename.dirname pat in + let base_pat = Filename.basename pat in + let dir' = if dir = "." && not (String.length pat > 1 && pat.[0] = '.') then "." else dir in + (try + let entries = Sys.readdir dir' in + Array.fold_left (fun acc entry -> + if glob_match base_pat entry then + let full = if dir' = "." then entry else Filename.concat dir' entry in + full :: acc + else acc + ) [] entries + |> List.sort String.compare + with Sys_error _ -> []) + in + match args with + | [String pat] -> List (List.map (fun s -> String s) (glob_paths pat)) + | _ -> raise (Eval_error "file-glob: (pattern)")); + + (* === File metadata + ops (Phase 5d) === *) + let stat_or = function + | String path -> (try Some (Unix.stat path) with _ -> None) + | _ -> raise (Eval_error "file: path must be a string") + in + register "file-size" (fun args -> + match args with + | [v] -> (match stat_or v with Some s -> Integer s.Unix.st_size | None -> Integer 0) + | _ -> raise (Eval_error "file-size: (path)")); + register "file-mtime" (fun args -> + match args with + | [v] -> (match stat_or v with Some s -> Integer (int_of_float s.Unix.st_mtime) | None -> Integer 0) + | _ -> raise (Eval_error "file-mtime: (path)")); + register "file-isfile?" (fun args -> + match args with + | [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_REG) | None -> Bool false) + | _ -> raise (Eval_error "file-isfile?: (path)")); + register "file-isdir?" (fun args -> + match args with + | [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_DIR) | None -> Bool false) + | _ -> raise (Eval_error "file-isdir?: (path)")); + register "file-readable?" (fun args -> + match args with + | [String path] -> + Bool (try Unix.access path [Unix.R_OK]; true with _ -> false) + | _ -> raise (Eval_error "file-readable?: (path)")); + register "file-writable?" (fun args -> + match args with + | [String path] -> + Bool (try Unix.access path [Unix.W_OK]; true with _ -> false) + | _ -> raise (Eval_error "file-writable?: (path)")); + register "file-stat" (fun args -> + match args with + | [v] -> + (match stat_or v with + | None -> Nil + | Some s -> + let d = Hashtbl.create 6 in + Hashtbl.replace d "size" (Integer s.Unix.st_size); + Hashtbl.replace d "mtime" (Integer (int_of_float s.Unix.st_mtime)); + Hashtbl.replace d "atime" (Integer (int_of_float s.Unix.st_atime)); + Hashtbl.replace d "ctime" (Integer (int_of_float s.Unix.st_ctime)); + Hashtbl.replace d "mode" (Integer s.Unix.st_perm); + Hashtbl.replace d "type" (String (match s.Unix.st_kind with + | Unix.S_REG -> "file" | Unix.S_DIR -> "directory" + | Unix.S_LNK -> "link" | Unix.S_CHR -> "characterSpecial" + | Unix.S_BLK -> "blockSpecial" | Unix.S_FIFO -> "fifo" + | Unix.S_SOCK -> "socket")); + Dict d) + | _ -> raise (Eval_error "file-stat: (path)")); + register "file-delete" (fun args -> + match args with + | [String path] -> + (try + if Sys.is_directory path then Unix.rmdir path + else Unix.unlink path + with + | Unix.Unix_error (Unix.ENOENT, _, _) -> () (* tolerate missing *) + | Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-delete: " ^ Unix.error_message e))); + Nil + | _ -> raise (Eval_error "file-delete: (path)")); + register "file-mkdir" (fun args -> + match args with + | [String path] -> + let rec mk p = + if p = "" || p = "." || p = "/" then () + else if Sys.file_exists p then () + else begin + mk (Filename.dirname p); + (try Unix.mkdir p 0o755 + with Unix.Unix_error (Unix.EEXIST, _, _) -> ()) + end + in + (try mk path + with Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-mkdir: " ^ Unix.error_message e))); + Nil + | _ -> raise (Eval_error "file-mkdir: (path)")); + register "file-copy" (fun args -> + match args with + | [String src; String dst] -> + (try + let ic = open_in_bin src in + let oc = open_out_bin dst in + let buf = Bytes.create 8192 in + let rec loop () = + let n = input ic buf 0 (Bytes.length buf) in + if n > 0 then (output oc buf 0 n; loop ()) + in + loop (); + close_in ic; + close_out oc; + Nil + with + | Sys_error msg -> raise (Eval_error ("file-copy: " ^ msg))) + | _ -> raise (Eval_error "file-copy: (src dst)")); + register "file-rename" (fun args -> + match args with + | [String src; String dst] -> + (try Sys.rename src dst with Sys_error msg -> raise (Eval_error ("file-rename: " ^ msg))); + Nil + | _ -> raise (Eval_error "file-rename: (src dst)")); + + (* === Channels (random-access + blocking control) === *) + let channel_table : (string, Unix.file_descr * string * bool ref * bool ref) Hashtbl.t = Hashtbl.create 16 in + let channel_next_id = ref 0 in + let parse_open_mode mode = + match mode with + | "r" -> [Unix.O_RDONLY] + | "w" -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] + | "a" -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND] + | "r+" -> [Unix.O_RDWR] + | "w+" -> [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC] + | "a+" -> [Unix.O_RDWR; Unix.O_CREAT; Unix.O_APPEND] + | _ -> raise (Eval_error ("channel-open: invalid mode " ^ mode)) + in + let chan_get name = + match Hashtbl.find_opt channel_table name with + | Some c -> c + | None -> raise (Eval_error ("channel: no such channel " ^ name)) + in + register "channel-open" (fun args -> + match args with + | [String path; String mode] -> + (try + let fd = Unix.openfile path (parse_open_mode mode) 0o644 in + let id = !channel_next_id in + incr channel_next_id; + let name = Printf.sprintf "file%d" id in + Hashtbl.replace channel_table name (fd, mode, ref false, ref true); + String name + with Unix.Unix_error (e, _, _) -> raise (Eval_error ("channel-open: " ^ Unix.error_message e))) + | _ -> raise (Eval_error "channel-open: (path mode)")); + + register "channel-close" (fun args -> + match args with + | [String name] -> + let (fd, _, _, _) = chan_get name in + (try Unix.close fd with _ -> ()); + Hashtbl.remove channel_table name; + Nil + | _ -> raise (Eval_error "channel-close: (channel)")); + + register "channel-read" (fun args -> + let (name, max_n) = match args with + | [String n] -> (n, -1) + | [String n; Integer m] -> (n, m) + | [String n; Number m] -> (n, int_of_float m) + | _ -> raise (Eval_error "channel-read: (channel ?n?)") + in + let (fd, _, eof, _) = chan_get name in + let chunk = 8192 in + let buf = Bytes.create chunk in + let buffer = Buffer.create chunk in + let total = ref 0 in + let stop = ref false in + while not !stop do + let want = if max_n < 0 then chunk else min chunk (max_n - !total) in + if want <= 0 then stop := true + else begin + try + let r = Unix.read fd buf 0 want in + if r = 0 then begin eof := true; stop := true end + else begin + Buffer.add_subbytes buffer buf 0 r; + total := !total + r + end + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> stop := true + end + done; + String (Buffer.contents buffer)); + + register "channel-read-line" (fun args -> + match args with + | [String name] -> + let (fd, _, eof, _) = chan_get name in + let buf = Buffer.create 80 in + let one = Bytes.create 1 in + let got_data = ref false in + let stop = ref false in + while not !stop do + try + let r = Unix.read fd one 0 1 in + if r = 0 then begin eof := true; stop := true end + else begin + got_data := true; + let c = Bytes.get one 0 in + if c = '\n' then stop := true + else Buffer.add_char buf c + end + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> stop := true + done; + if !got_data then String (Buffer.contents buf) else Nil + | _ -> raise (Eval_error "channel-read-line: (channel)")); + + register "channel-write" (fun args -> + match args with + | [String name; String s] -> + let (fd, _, _, _) = chan_get name in + let b = Bytes.of_string s in + let n = Bytes.length b in + let written = ref 0 in + while !written < n do + (try + let w = Unix.write fd b !written (n - !written) in + written := !written + w + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> + (* short write — let caller retry *) + written := n) + done; + Nil + | _ -> raise (Eval_error "channel-write: (channel string)")); + + register "channel-flush" (fun args -> + match args with + | [String name] -> let _ = chan_get name in Nil (* no userspace buffer *) + | _ -> raise (Eval_error "channel-flush: (channel)")); + + register "channel-seek" (fun args -> + let (name, offset, whence) = match args with + | [String n; Integer o] -> (n, o, "start") + | [String n; Number o] -> (n, int_of_float o, "start") + | [String n; Integer o; String w] -> (n, o, w) + | [String n; Number o; String w] -> (n, int_of_float o, w) + | _ -> raise (Eval_error "channel-seek: (channel offset ?whence?)") + in + let (fd, _, eof, _) = chan_get name in + let cmd = match whence with + | "start" -> Unix.SEEK_SET + | "current" -> Unix.SEEK_CUR + | "end" -> Unix.SEEK_END + | _ -> raise (Eval_error ("channel-seek: invalid whence " ^ whence)) + in + let _ = Unix.lseek fd offset cmd in + eof := false; + Nil); + + register "channel-tell" (fun args -> + match args with + | [String name] -> + let (fd, _, _, _) = chan_get name in + Integer (Unix.lseek fd 0 Unix.SEEK_CUR) + | _ -> raise (Eval_error "channel-tell: (channel)")); + + register "channel-eof?" (fun args -> + match args with + | [String name] -> + let (_, _, eof, _) = chan_get name in + Bool !eof + | _ -> raise (Eval_error "channel-eof?: (channel)")); + + register "channel-blocking?" (fun args -> + match args with + | [String name] -> + let (_, _, _, blocking) = chan_get name in + Bool !blocking + | _ -> raise (Eval_error "channel-blocking?: (channel)")); + + register "channel-set-blocking!" (fun args -> + match args with + | [String name; Bool b] -> + let (fd, _, _, blocking) = chan_get name in + blocking := b; + (try + if b then Unix.clear_nonblock fd + else Unix.set_nonblock fd + with _ -> ()); + Nil + | _ -> raise (Eval_error "channel-set-blocking!: (channel bool)")); + + (* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *) + let resolve_inet_addr host = + if host = "" || host = "0.0.0.0" then Unix.inet_addr_any + else if host = "localhost" then Unix.inet_addr_loopback + else + try Unix.inet_addr_of_string host + with _ -> + try + let entry = Unix.gethostbyname host in + if Array.length entry.Unix.h_addr_list = 0 then + raise (Eval_error ("socket: cannot resolve " ^ host)) + else entry.Unix.h_addr_list.(0) + with Not_found -> raise (Eval_error ("socket: cannot resolve " ^ host)) + in + let port_of v = match v with + | Integer n -> n + | Number n -> int_of_float n + | _ -> raise (Eval_error "socket: port must be a number") + in + let alloc_chan_name () = + let id = !channel_next_id in + incr channel_next_id; + Printf.sprintf "sock%d" id + in + + register "socket-connect" (fun args -> + match args with + | [String host; port_v] -> + let port = port_of port_v in + let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in + let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + (try Unix.connect sock addr + with Unix.Unix_error (e, _, _) -> + (try Unix.close sock with _ -> ()); + raise (Eval_error ("socket-connect: " ^ Unix.error_message e))); + let name = alloc_chan_name () in + Hashtbl.replace channel_table name (sock, "rw", ref false, ref true); + String name + | _ -> raise (Eval_error "socket-connect: (host port)")); + + (* Non-blocking connect: returns channel immediately. Connection completes + when the channel becomes writable; query channel-async-error? after to + confirm success or get the error. *) + register "socket-connect-async" (fun args -> + match args with + | [String host; port_v] -> + let port = port_of port_v in + let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in + let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.set_nonblock sock; + (try Unix.connect sock addr + with + | Unix.Unix_error (Unix.EINPROGRESS, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> () + | Unix.Unix_error (e, _, _) -> + (try Unix.close sock with _ -> ()); + raise (Eval_error ("socket-connect-async: " ^ Unix.error_message e))); + let name = alloc_chan_name () in + Hashtbl.replace channel_table name (sock, "rw", ref false, ref false); + String name + | _ -> raise (Eval_error "socket-connect-async: (host port)")); + + (* After a non-blocking connect completes (channel writable), check whether + the connect succeeded. Returns "" on success, error message on failure. *) + register "channel-async-error" (fun args -> + match args with + | [String name] -> + let (fd, _, _, _) = chan_get name in + (try + let err = Unix.getsockopt_error fd in + match err with + | None -> String "" + | Some e -> String (Unix.error_message e) + with + | Unix.Unix_error (e, _, _) -> String (Unix.error_message e)) + | _ -> raise (Eval_error "channel-async-error: (channel)")); + + register "socket-server" (fun args -> + let (host, port) = match args with + | [port_v] -> ("", port_of port_v) + | [String h; port_v] -> (h, port_of port_v) + | _ -> raise (Eval_error "socket-server: (port) or (host port)") + in + let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in + let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.setsockopt sock Unix.SO_REUSEADDR true; + (try Unix.bind sock addr + with Unix.Unix_error (e, _, _) -> + (try Unix.close sock with _ -> ()); + raise (Eval_error ("socket-server: bind: " ^ Unix.error_message e))); + Unix.listen sock 8; + let name = alloc_chan_name () in + Hashtbl.replace channel_table name (sock, "server", ref false, ref true); + String name); + + register "socket-accept" (fun args -> + match args with + | [String name] -> + let (sock, _, _, _) = chan_get name in + let (client_sock, client_addr) = + try Unix.accept sock + with Unix.Unix_error (e, _, _) -> + raise (Eval_error ("socket-accept: " ^ Unix.error_message e)) + in + let (host_str, port) = match client_addr with + | Unix.ADDR_INET (addr, p) -> (Unix.string_of_inet_addr addr, p) + | Unix.ADDR_UNIX path -> (path, 0) + in + let client_name = alloc_chan_name () in + Hashtbl.replace channel_table client_name (client_sock, "rw", ref false, ref true); + let d = Hashtbl.create 3 in + Hashtbl.replace d "channel" (String client_name); + Hashtbl.replace d "host" (String host_str); + Hashtbl.replace d "port" (Integer port); + Dict d + | _ -> raise (Eval_error "socket-accept: (server-channel)")); + + (* io-select-channels: (read-list write-list timeout-ms) → {:readable [...] :writable [...]} + timeout-ms < 0 → block indefinitely; 0 → poll. Returns ready channel names. *) + register "io-select-channels" (fun args -> + let to_ms v = match v with + | Integer n -> n + | Number n -> int_of_float n + | _ -> raise (Eval_error "io-select-channels: timeout must be a number") + in + let to_list v = match v with + | List xs | ListRef { contents = xs } -> xs + | Nil -> [] + | _ -> raise (Eval_error "io-select-channels: expected list") + in + let chan_name_of v = match v with + | String s -> s + | _ -> raise (Eval_error "io-select-channels: channel must be a string") + in + let (read_list, write_list, timeout_ms) = match args with + | [r; w; t] -> (to_list r, to_list w, to_ms t) + | _ -> raise (Eval_error "io-select-channels: (read-list write-list timeout-ms)") + in + let read_pairs = List.map (fun v -> + let name = chan_name_of v in + let (fd, _, _, _) = chan_get name in (name, fd)) read_list in + let write_pairs = List.map (fun v -> + let name = chan_name_of v in + let (fd, _, _, _) = chan_get name in (name, fd)) write_list in + let read_fds = List.map snd read_pairs in + let write_fds = List.map snd write_pairs in + let timeout = if timeout_ms < 0 then -1.0 else float_of_int timeout_ms /. 1000.0 in + let (ready_r, ready_w, _) = + try Unix.select read_fds write_fds [] timeout + with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], []) + in + let names_of pairs ready = + List.filter_map (fun (n, fd) -> + if List.exists (fun rfd -> rfd = fd) ready then Some (String n) else None + ) pairs + in + let d = Hashtbl.create 2 in + Hashtbl.replace d "readable" (List (names_of read_pairs ready_r)); + Hashtbl.replace d "writable" (List (names_of write_pairs ready_w)); + Dict d); + + (* === Clock === *) + register "clock-seconds" (fun args -> + match args with + | [] -> Integer (int_of_float (Unix.gettimeofday ())) + | _ -> raise (Eval_error "clock-seconds: no args")); + + register "clock-milliseconds" (fun args -> + match args with + | [] -> Integer (int_of_float (Unix.gettimeofday () *. 1000.0)) + | _ -> raise (Eval_error "clock-milliseconds: no args")); + + let format_tm tm tz_label = + fun fmt -> + let buf = Buffer.create 32 in + let n = String.length fmt in + let i = ref 0 in + while !i < n do + if fmt.[!i] = '%' && !i + 1 < n then begin + (match fmt.[!i + 1] with + | 'Y' -> Buffer.add_string buf (Printf.sprintf "%04d" (1900 + tm.Unix.tm_year)) + | 'y' -> Buffer.add_string buf (Printf.sprintf "%02d" ((1900 + tm.Unix.tm_year) mod 100)) + | 'm' -> Buffer.add_string buf (Printf.sprintf "%02d" (tm.Unix.tm_mon + 1)) + | 'd' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_mday) + | 'e' -> Buffer.add_string buf (Printf.sprintf "%2d" tm.Unix.tm_mday) + | 'H' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_hour) + | 'I' -> let h = tm.Unix.tm_hour mod 12 in + Buffer.add_string buf (Printf.sprintf "%02d" (if h = 0 then 12 else h)) + | 'p' -> Buffer.add_string buf (if tm.Unix.tm_hour < 12 then "AM" else "PM") + | 'M' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_min) + | 'S' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_sec) + | 'j' -> Buffer.add_string buf (Printf.sprintf "%03d" (tm.Unix.tm_yday + 1)) + | 'w' -> Buffer.add_string buf (string_of_int tm.Unix.tm_wday) + | 'Z' -> Buffer.add_string buf tz_label + | 'a' -> let days = [|"Sun";"Mon";"Tue";"Wed";"Thu";"Fri";"Sat"|] in + Buffer.add_string buf days.(tm.Unix.tm_wday) + | 'A' -> let days = [|"Sunday";"Monday";"Tuesday";"Wednesday";"Thursday";"Friday";"Saturday"|] in + Buffer.add_string buf days.(tm.Unix.tm_wday) + | 'b' | 'h' -> let mons = [|"Jan";"Feb";"Mar";"Apr";"May";"Jun";"Jul";"Aug";"Sep";"Oct";"Nov";"Dec"|] in + Buffer.add_string buf mons.(tm.Unix.tm_mon) + | 'B' -> let mons = [|"January";"February";"March";"April";"May";"June";"July";"August";"September";"October";"November";"December"|] in + Buffer.add_string buf mons.(tm.Unix.tm_mon) + | '%' -> Buffer.add_char buf '%' + | c -> Buffer.add_char buf '%'; Buffer.add_char buf c); + i := !i + 2 + end else begin + Buffer.add_char buf fmt.[!i]; + incr i + end + done; + Buffer.contents buf + in + register "clock-format" (fun args -> + let (t, fmt, tz) = match args with + | [Integer t] -> (t, "%a %b %e %H:%M:%S %Z %Y", "utc") + | [Integer t; String f] -> (t, f, "utc") + | [Integer t; String f; String z] -> (t, f, z) + | _ -> raise (Eval_error "clock-format: (seconds [format [tz]])") + in + let tm = + if tz = "local" then Unix.localtime (float_of_int t) + else Unix.gmtime (float_of_int t) + in + let label = if tz = "local" then "" else "UTC" in + String (format_tm tm label fmt)); + + (* clock-scan: parse a date string with format, return seconds. + Supports the same format specifiers as clock-format (fixed-width ones). + tz: "utc" (default) or "local". *) + let timegm (tm : Unix.tm) = + let is_leap y = y mod 4 = 0 && (y mod 100 <> 0 || y mod 400 = 0) in + let days_in_month = [|31;28;31;30;31;30;31;31;30;31;30;31|] in + let year = tm.Unix.tm_year + 1900 in + let mon = tm.Unix.tm_mon in + let mday = tm.Unix.tm_mday in + let total_days = ref 0 in + if year >= 1970 then begin + for y = 1970 to year - 1 do + total_days := !total_days + (if is_leap y then 366 else 365) + done + end else begin + for y = year to 1969 do + total_days := !total_days - (if is_leap y then 366 else 365) + done + end; + for m = 0 to mon - 1 do + total_days := !total_days + days_in_month.(m); + if m = 1 && is_leap year then incr total_days + done; + total_days := !total_days + mday - 1; + !total_days * 86400 + + tm.Unix.tm_hour * 3600 + + tm.Unix.tm_min * 60 + + tm.Unix.tm_sec + in + register "clock-scan" (fun args -> + let (str, fmt, tz) = match args with + | [String s; String f] -> (s, f, "utc") + | [String s; String f; String z] -> (s, f, z) + | _ -> raise (Eval_error "clock-scan: (str fmt [tz])") + in + let n = String.length fmt and sn = String.length str in + let tm = ref { Unix.tm_year = 70; tm_mon = 0; tm_mday = 1; + tm_hour = 0; tm_min = 0; tm_sec = 0; + tm_wday = 0; tm_yday = 0; tm_isdst = false } in + let i = ref 0 and j = ref 0 in + let read_n_digits k = + let s = ref "" in + let cnt = ref 0 in + while !cnt < k && !j < sn && str.[!j] >= '0' && str.[!j] <= '9' do + s := !s ^ String.make 1 str.[!j]; + incr j; incr cnt + done; + if !s = "" then 0 else int_of_string !s + in + let skip_ws () = + while !j < sn && (str.[!j] = ' ' || str.[!j] = '\t') do incr j done + in + while !i < n do + if fmt.[!i] = '%' && !i + 1 < n then begin + (match fmt.[!i + 1] with + | 'Y' -> tm := { !tm with tm_year = read_n_digits 4 - 1900 } + | 'y' -> let y = read_n_digits 2 in + tm := { !tm with tm_year = (if y < 70 then 100 + y else y) } + | 'm' -> tm := { !tm with tm_mon = read_n_digits 2 - 1 } + | 'd' | 'e' -> skip_ws (); tm := { !tm with tm_mday = read_n_digits 2 } + | 'H' | 'I' -> tm := { !tm with tm_hour = read_n_digits 2 } + | 'M' -> tm := { !tm with tm_min = read_n_digits 2 } + | 'S' -> tm := { !tm with tm_sec = read_n_digits 2 } + | '%' -> if !j < sn && str.[!j] = '%' then incr j + | _ -> () (* unsupported specifier — skip *) + ); + i := !i + 2 + end else begin + if fmt.[!i] = ' ' then skip_ws () + else if !j < sn && str.[!j] = fmt.[!i] then incr j; + incr i + end + done; + let secs = + if tz = "local" then int_of_float (fst (Unix.mktime !tm)) + else timegm !tm + in + Integer secs); + + (* === Env-as-value (Phase 4) === *) + + (* env-lookup: (env key) → value or nil. Works on Env, Dict, or Nil. *) + register "env-lookup" (fun args -> + let unwrap = function + | Env e -> e + | Nil -> make_env () + | _ -> raise (Eval_error "env-lookup: first arg must be an environment") in + match args with + | [env_val; key] -> + let e = unwrap env_val in + let k = value_to_string key in + if env_has e k then env_get e k else Nil + | _ -> raise (Eval_error "env-lookup: (env key)")); + + (* env-extend: (env [key val ...]) → new child env with optional bindings. *) + register "env-extend" (fun args -> + match args with + | [] -> raise (Eval_error "env-extend: requires at least one arg") + | env_val :: pairs -> + let parent_env = match env_val with + | Env e -> e + | Nil -> make_env () + | _ -> raise (Eval_error "env-extend: first arg must be an environment") in + let child = env_extend parent_env in + let rec add_bindings = function + | [] -> () + | k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest + | [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in + add_bindings pairs; + Env child) diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index 590ea6de..2b12cc22 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 (match !_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)))) (* 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,82 @@ 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 () = ignore (match_check_exhaustiveness val' clauses env) 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)))))) + +(* match-check-exhaustiveness — Step 8 hand-patched into sx_ref.ml *) +and match_check_exhaustiveness val' clauses env = + let is_else_pat p = + match p with + | Symbol "_" | Symbol "else" -> true + | Keyword "else" -> true + | _ -> false + in + let clause_is_else c = + match c with + | List (p :: _) -> is_else_pat p + | _ -> false + in + let clause_ctor_name c = + match c with + | List (List (Symbol n :: _) :: _) -> Some n + | _ -> None + in + let type_name_opt = match val' with + | AdtValue a -> Some a.av_type + | Dict d -> + (match Hashtbl.find_opt d "_adt" with + | Some (Bool true) -> + (match Hashtbl.find_opt d "_type" with + | Some (String s) -> Some s + | _ -> None) + | _ -> None) + | _ -> None + in + match type_name_opt with + | None -> Nil + | Some type_name -> + if not (sx_truthy (env_has env (String "*adt-registry*"))) then Nil + else + let registry = env_get env (String "*adt-registry*") in + let registered = match registry with + | Dict r -> + (match Hashtbl.find_opt r type_name with + | Some (List ctors) -> Some ctors + | _ -> None) + | _ -> None in + (match registered with + | None -> Nil + | Some ctor_vals -> + let clauses_list = match clauses with List xs -> xs | _ -> [] in + if List.exists clause_is_else clauses_list then Nil + else + let clause_ctors = List.filter_map clause_ctor_name clauses_list in + let registered_names = List.filter_map (function + | String s -> Some s | _ -> None) ctor_vals in + let missing = List.filter (fun c -> not (List.mem c clause_ctors)) registered_names in + if missing = [] then Nil + else begin + if not (sx_truthy (env_has env (String "*adt-warned*"))) then + ignore (env_bind env (String "*adt-warned*") (Dict (Hashtbl.create 4))); + let warned = env_get env (String "*adt-warned*") in + let key = type_name ^ "|" ^ String.concat "," missing in + let already = match warned with + | Dict w -> (match Hashtbl.find_opt w key with Some (Bool true) -> true | _ -> false) + | _ -> false in + if already then Nil + else begin + (match warned with + | Dict w -> Hashtbl.replace w key (Bool true) + | _ -> ()); + let msg = "[sx] match: non-exhaustive — " ^ type_name ^ ": missing " ^ String.concat ", " missing in + ignore (host_warn (String msg)); + Nil + end + end) (* step-sf-handler-bind *) and step_sf_handler_bind args env kont = @@ -784,6 +866,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 +974,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 +1006,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 +1024,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 []))))) @@ -958,7 +1052,14 @@ let cek_run_iterative state = s := cek_step !s done; (match cek_suspended_p !s with - | Bool true -> raise (Eval_error "IO suspension in non-IO context") + | Bool true -> + (* Propagate suspension via the OCaml-side hook so it converts to + VmSuspended and flows to the outer driver (value_to_js / resume + callback). Without the hook (pure CEK harness), keep the legacy + error so test runners surface the misuse. *) + (match !_cek_io_suspend_hook with + | Some hook -> hook !s + | None -> raise (Eval_error "IO suspension in non-IO context")) | _ -> cek_value !s) with Eval_error msg -> _last_error_kont_ref := cek_kont !s; @@ -1006,5 +1107,197 @@ 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 + | AdtValue a -> Bool (a.av_type = type_name) + | _ -> 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 + AdtValue { + av_type = type_name; + av_ctor = cn; + av_fields = Array.of_list ctor_args; + })); + env_bind_v (cn ^ "?") + (NativeFn (cn ^ "?", fun pargs -> + (match pargs with + | [v] -> + (match v with + | AdtValue a -> Bool (a.av_ctor = cn) + | _ -> 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 + | AdtValue a -> + if idx < Array.length a.av_fields then a.av_fields.(idx) + else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds")) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT"))) + | _ -> 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..2d907457 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -6,11 +6,72 @@ open Sx_types -(** Call a registered primitive by name. *) +(** Fast path equality — same as Sx_primitives.safe_eq for the common cases + that show up in hot dispatch (string vs string, etc). Falls through to + the registered "=" primitive for complex cases. *) +let rec _fast_eq a b = + if a == b then true + else match a, b with + | String x, String 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 + | Bool x, Bool y -> x = y + | Nil, Nil -> true + | Symbol x, Symbol y -> x = y + | Keyword x, Keyword y -> x = y + | List la, List lb -> + (try List.for_all2 _fast_eq la lb with Invalid_argument _ -> false) + | _ -> false + +(** Call a registered primitive by name. + Fast path for hot dispatch primitives ([=], [<], [>], [<=], [>=], [empty?], + [first], [rest], [len]) skips the Hashtbl lookup entirely — these are + called millions of times in the CEK [step_continue]/[step_eval] dispatch. *) let prim_call name args = - match Hashtbl.find_opt Sx_primitives.primitives name with - | Some f -> f args - | None -> raise (Eval_error ("Unknown primitive: " ^ name)) + (* Hot path: most-frequently-called primitives by step_continue dispatch *) + match name, args with + | "=", [a; b] -> Bool (_fast_eq a b) + | "empty?", [List []] -> Bool true + | "empty?", [List _] -> Bool false + | "empty?", [ListRef { contents = [] }] -> Bool true + | "empty?", [ListRef _] -> Bool false + | "empty?", [Nil] -> Bool true + | "first", [List (x :: _)] -> x + | "first", [List []] -> Nil + | "first", [ListRef { contents = (x :: _) }] -> x + | "first", [ListRef _] -> Nil + | "first", [Nil] -> Nil + | "rest", [List (_ :: xs)] -> List xs + | "rest", [List []] -> List [] + | "rest", [ListRef { contents = (_ :: xs) }] -> List xs + | "rest", [ListRef _] -> List [] + | "rest", [Nil] -> List [] + | "len", [List l] -> Integer (List.length l) + | "len", [ListRef r] -> Integer (List.length !r) + | "len", [String s] -> Integer (String.length s) + | "len", [Nil] -> Integer 0 + | "<", [Integer x; Integer y] -> Bool (x < y) + | "<", [Number x; Number y] -> Bool (x < y) + | "<", [Integer x; Number y] -> Bool (float_of_int x < y) + | "<", [Number x; Integer y] -> Bool (x < float_of_int y) + | ">", [Integer x; Integer y] -> Bool (x > y) + | ">", [Number x; Number y] -> Bool (x > y) + | ">", [Integer x; Number y] -> Bool (float_of_int x > y) + | ">", [Number x; Integer y] -> Bool (x > float_of_int y) + | "<=", [Integer x; Integer y] -> Bool (x <= y) + | "<=", [Number x; Number y] -> Bool (x <= y) + | "<=", [Integer x; Number y] -> Bool (float_of_int x <= y) + | "<=", [Number x; Integer y] -> Bool (x <= float_of_int y) + | ">=", [Integer x; Integer y] -> Bool (x >= y) + | ">=", [Number x; Number y] -> Bool (x >= y) + | ">=", [Integer x; Number y] -> Bool (float_of_int x >= y) + | ">=", [Number x; Integer y] -> Bool (x >= float_of_int y) + | _ -> + match Hashtbl.find_opt Sx_primitives.primitives name with + | Some f -> f args + | None -> raise (Eval_error ("Unknown primitive: " ^ name)) (** Convert any SX value to an OCaml string (internal). *) let value_to_str = function @@ -46,7 +107,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 +217,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 @@ -206,8 +270,17 @@ let get_val container key = | _ -> Nil) | Dict d, String k -> dict_get d k | Dict d, Keyword k -> dict_get d k + | AdtValue a, String k | AdtValue a, Keyword k -> + (match k with + | "_adt" -> Bool true + | "_type" -> String a.av_type + | "_ctor" -> String a.av_ctor + | "_fields" -> List (Array.to_list a.av_fields) + | _ -> Nil) | (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,19 +454,28 @@ 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)) +let host_warn msg = + prerr_endline (value_to_str msg); + Nil + let dynamic_wind_call before body after _env = ignore (sx_call before []); let result = sx_call body [] in @@ -529,3 +611,4 @@ let jit_try_call f args = (match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; _jit_skip_sentinel) | _ -> incr _jit_skip; _jit_skip_sentinel + diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index fe7ee53f..b7b81dda 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,35 @@ 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. *) + | AdtValue of adt_value (** Native algebraic data type instance — opaque sum type. *) + +(** Algebraic data type instance — produced by [define-type] constructors. + [av_type] is the type name (e.g. "Maybe"), [av_ctor] is the constructor + name (e.g. "Just"), [av_fields] are the positional field values. *) +and adt_value = { + av_type : string; + av_ctor : string; + av_fields : value array; +} + +(** 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 +422,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 +492,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 +505,7 @@ let type_of = function | Macro _ -> "macro" | Thunk _ -> "thunk" | Continuation (_, _) -> "continuation" - | CallccContinuation _ -> "continuation" + | CallccContinuation (_, _) -> "continuation" | NativeFn _ -> "function" | Signal _ -> "signal" | RawHTML _ -> "raw-html" @@ -488,6 +520,17 @@ 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" + | AdtValue a -> a.av_type let is_nil = function Nil -> true | _ -> false let is_lambda = function Lambda _ -> true | _ -> false @@ -503,7 +546,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 +659,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)) @@ -773,13 +817,15 @@ let dict_vals (d : dict) = (** {1 Value display} *) -let rec inspect = function - | Nil -> "nil" - | Bool true -> "true" - | Bool false -> "false" - | Number n -> format_number n +(* Single shared buffer for the entire inspect recursion — eliminates + the per-level [String.concat (List.map inspect ...)] allocation. *) +let rec inspect_into buf = function + | Nil -> Buffer.add_string buf "nil" + | Bool true -> Buffer.add_string buf "true" + | Bool false -> Buffer.add_string buf "false" + | Integer n -> Buffer.add_string buf (string_of_int n) + | Number n -> Buffer.add_string buf (format_number n) | String s -> - let buf = Buffer.create (String.length s + 2) in Buffer.add_char buf '"'; String.iter (function | '"' -> Buffer.add_string buf "\\\"" @@ -788,46 +834,129 @@ let rec inspect = function | '\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 - | Symbol s -> s - | Keyword k -> ":" ^ k + Buffer.add_char buf '"' + | Symbol s -> Buffer.add_string buf s + | Keyword k -> Buffer.add_char buf ':'; Buffer.add_string buf k | List items | ListRef { contents = items } -> - "(" ^ String.concat " " (List.map inspect items) ^ ")" + Buffer.add_char buf '('; + (match items with + | [] -> () + | x :: rest -> + inspect_into buf x; + List.iter (fun v -> Buffer.add_char buf ' '; inspect_into buf v) rest); + Buffer.add_char buf ')' | Dict d -> - let pairs = Hashtbl.fold (fun k v acc -> - (Printf.sprintf ":%s %s" k (inspect v)) :: acc) d [] in - "{" ^ String.concat " " pairs ^ "}" + Buffer.add_char buf '{'; + let first = ref true in + Hashtbl.iter (fun k v -> + if !first then first := false else Buffer.add_char buf ' '; + Buffer.add_char buf ':'; Buffer.add_string buf k; + Buffer.add_char buf ' '; inspect_into buf v) d; + Buffer.add_char buf '}' | Lambda l -> let tag = match l.l_name with Some n -> n | None -> "lambda" in - Printf.sprintf "<%s(%s)>" tag (String.concat ", " l.l_params) + Buffer.add_char buf '<'; Buffer.add_string buf tag; + Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " l.l_params); + Buffer.add_string buf ")>" | Component c -> - Printf.sprintf "" c.c_name (String.concat ", " c.c_params) + Buffer.add_string buf "" | Island i -> - Printf.sprintf "" i.i_name (String.concat ", " i.i_params) + Buffer.add_string buf "" | Macro m -> let tag = match m.m_name with Some n -> n | None -> "macro" in - Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params) - | Thunk _ -> "" - | Continuation (_, _) -> "" - | CallccContinuation _ -> "" - | NativeFn (name, _) -> Printf.sprintf "" name - | Signal _ -> "" - | RawHTML s -> Printf.sprintf "\"\"" (String.length s) - | Spread _ -> "" - | SxExpr s -> Printf.sprintf "\"\"" (String.length s) - | Env _ -> "" - | CekState _ -> "" - | CekFrame f -> Printf.sprintf "" f.cf_type - | VmClosure cl -> Printf.sprintf "" (match cl.vm_name with Some n -> n | None -> "anon") + Buffer.add_char buf '<'; Buffer.add_string buf tag; + Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " m.m_params); + Buffer.add_string buf ")>" + | Thunk _ -> Buffer.add_string buf "" + | Continuation (_, _) -> Buffer.add_string buf "" + | CallccContinuation (_, _) -> Buffer.add_string buf "" + | NativeFn (name, _) -> + Buffer.add_string buf "' + | Signal _ -> Buffer.add_string buf "" + | RawHTML s -> + Buffer.add_string buf "\"\"" + | Spread _ -> Buffer.add_string buf "" + | SxExpr s -> + Buffer.add_string buf "\"\"" + | Env _ -> Buffer.add_string buf "" + | CekState _ -> Buffer.add_string buf "" + | CekFrame f -> + Buffer.add_string buf "' + | VmClosure cl -> + Buffer.add_string buf " n | None -> "anon"); + Buffer.add_char buf '>' | Record r -> - let fields = Array.to_list (Array.mapi (fun i v -> - Printf.sprintf "%s=%s" r.r_type.rt_fields.(i) (inspect v) - ) r.r_fields) in - Printf.sprintf "" r.r_type.rt_name (String.concat " " fields) - | Parameter p -> Printf.sprintf "" p.pm_uid + Buffer.add_string buf " + Buffer.add_char buf ' '; + Buffer.add_string buf r.r_type.rt_fields.(i); + Buffer.add_char buf '='; + inspect_into buf v) r.r_fields; + Buffer.add_char buf '>' + | Parameter p -> + Buffer.add_string buf "' | Vector arr -> - let elts = Array.to_list (Array.map inspect arr) in - 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) + Buffer.add_string buf "#("; + Array.iteri (fun i v -> + if i > 0 then Buffer.add_char buf ' '; + inspect_into buf v) arr; + Buffer.add_char buf ')' + | VmFrame f -> + Buffer.add_string buf (Printf.sprintf "" f.vf_ip f.vf_base) + | VmMachine m -> + Buffer.add_string buf (Printf.sprintf "" m.vm_sp (List.length m.vm_frames)) + | StringBuffer b -> + Buffer.add_string buf (Printf.sprintf "" (Buffer.length b)) + | HashTable ht -> + Buffer.add_string buf (Printf.sprintf "" (Hashtbl.length ht)) + | Char n -> + Buffer.add_string buf "#\\"; + (match n with + | 32 -> Buffer.add_string buf "space" + | 10 -> Buffer.add_string buf "newline" + | 9 -> Buffer.add_string buf "tab" + | 13 -> Buffer.add_string buf "return" + | 0 -> Buffer.add_string buf "nul" + | 27 -> Buffer.add_string buf "escape" + | 127 -> Buffer.add_string buf "delete" + | 8 -> Buffer.add_string buf "backspace" + | _ -> Buffer.add_utf_8_uchar buf (Uchar.of_int n)) + | Eof -> Buffer.add_string buf "#!eof" + | Port { sp_kind = PortInput (_, pos); sp_closed } -> + Buffer.add_string buf (Printf.sprintf "" !pos (if sp_closed then ":closed" else "")) + | Port { sp_kind = PortOutput b; sp_closed } -> + Buffer.add_string buf (Printf.sprintf "" (Buffer.length b) (if sp_closed then ":closed" else "")) + | Rational (n, d) -> + Buffer.add_string buf (string_of_int n); Buffer.add_char buf '/'; + Buffer.add_string buf (string_of_int d) + | SxSet ht -> + Buffer.add_string buf (Printf.sprintf "" (Hashtbl.length ht)) + | SxRegexp (src, flags, _) -> + Buffer.add_string buf "#/"; Buffer.add_string buf src; + Buffer.add_char buf '/'; Buffer.add_string buf flags + | SxBytevector b -> + Buffer.add_string buf "#u8("; + let n = Bytes.length b in + for i = 0 to n - 1 do + if i > 0 then Buffer.add_char buf ' '; + Buffer.add_string buf (string_of_int (Char.code (Bytes.get b i))) + done; + Buffer.add_char buf ')' + | AdtValue a -> + Buffer.add_char buf '('; Buffer.add_string buf a.av_ctor; + Array.iter (fun v -> Buffer.add_char buf ' '; inspect_into buf v) a.av_fields; + Buffer.add_char buf ')' + +let inspect v = + let buf = Buffer.create 64 in + inspect_into buf v; + Buffer.contents buf diff --git a/hosts/ocaml/lib/sx_vm.ml b/hosts/ocaml/lib/sx_vm.ml index 520f8785..330316e3 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. *) @@ -326,7 +327,18 @@ and call_closure_reuse cl args = vm.sp <- saved_sp; raise e); vm.frames <- saved_frames; - pop vm + (* Snapshot/restore sp around the popped result. + OP_RETURN normally leaves sp = saved_sp + 1, but the bytecode-exhausted + path (or a callee that returns a closure whose own RETURN leaves extra + stack residue) can leave sp inconsistent. Read the result at the + expected slot and reset sp explicitly so the parent frame's + intermediate values are not corrupted. *) + let result = + if vm.sp > saved_sp then vm.stack.(vm.sp - 1) + else Nil + in + vm.sp <- saved_sp; + result | None -> call_closure cl args cl.vm_env_ref @@ -630,7 +642,9 @@ and run vm = (* Read upvalue descriptors from bytecode *) let uv_count = match code_val with | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with - | Some (Number n) -> int_of_float n | _ -> 0) + | Some (Integer n) -> n + | Some (Number n) -> int_of_float n + | _ -> 0) | _ -> 0 in let upvalues = Array.init uv_count (fun _ -> @@ -730,51 +744,67 @@ and run vm = | 160 (* OP_ADD *) -> let b = pop vm and a = pop vm in push vm (match a, b with + | Integer x, Integer y -> Integer (x + y) | Number x, Number y -> Number (x +. y) + | Integer x, Number y -> Number (float_of_int x +. y) + | Number x, Integer y -> Number (x +. float_of_int y) | _ -> (Hashtbl.find Sx_primitives.primitives "+") [a; b]) | 161 (* OP_SUB *) -> let b = pop vm and a = pop vm in push vm (match a, b with + | Integer x, Integer y -> Integer (x - y) | Number x, Number y -> Number (x -. y) + | Integer x, Number y -> Number (float_of_int x -. y) + | Number x, Integer y -> Number (x -. float_of_int y) | _ -> (Hashtbl.find Sx_primitives.primitives "-") [a; b]) | 162 (* OP_MUL *) -> let b = pop vm and a = pop vm in push vm (match a, b with + | Integer x, Integer y -> Integer (x * y) | Number x, Number y -> Number (x *. y) + | Integer x, Number y -> Number (float_of_int x *. y) + | Number x, Integer y -> Number (x *. float_of_int y) | _ -> (Hashtbl.find Sx_primitives.primitives "*") [a; b]) | 163 (* OP_DIV *) -> let b = pop vm and a = pop vm in push vm (match a, b with + | Integer x, Integer y when y <> 0 && x mod y = 0 -> Integer (x / y) + | Integer x, Integer y -> Number (float_of_int x /. float_of_int y) | Number x, Number y -> Number (x /. y) + | Integer x, Number y -> Number (float_of_int x /. y) + | Number x, Integer y -> Number (x /. float_of_int y) | _ -> (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 (Bool (Sx_runtime._fast_eq a b)) | 165 (* OP_LT *) -> let b = pop vm and a = pop vm in push vm (match a, b with + | Integer x, Integer y -> Bool (x < y) | Number x, Number y -> Bool (x < y) + | Integer x, Number y -> Bool (float_of_int x < y) + | Number x, Integer y -> Bool (x < float_of_int y) | String x, String y -> Bool (x < y) - | _ -> (Hashtbl.find Sx_primitives.primitives "<") [a; b]) + | _ -> Sx_runtime.prim_call "<" [a; b]) | 166 (* OP_GT *) -> let b = pop vm and a = pop vm in push vm (match a, b with + | Integer x, Integer y -> Bool (x > y) | Number x, Number y -> Bool (x > y) + | Integer x, Number y -> Bool (float_of_int x > y) + | Number x, Integer y -> Bool (x > float_of_int y) | String x, String y -> Bool (x > y) - | _ -> (Hashtbl.find Sx_primitives.primitives ">") [a; b]) + | _ -> Sx_runtime.prim_call ">" [a; b]) | 167 (* OP_NOT *) -> let v = pop vm in push vm (Bool (not (sx_truthy v))) | 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 @@ -887,9 +917,17 @@ let resume_vm vm result = let rec restore_reuse pending = match pending with | [] -> () - | (saved_frames, _saved_sp) :: rest -> + | (saved_frames, saved_sp) :: rest -> let callback_result = pop vm in vm.frames <- saved_frames; + (* Restore sp to the value captured before the suspended callee was + pushed. The callee's locals/temps may still be on the stack above + saved_sp; without this reset, subsequent LOCAL_GET/SET in the + caller frame (e.g. letrec sibling bindings waiting on the call) + see stale callee data instead of their own slots. Mirrors the + OP_RETURN+sp-reset semantics that sync `call_closure_reuse` + relies on for clean caller-frame state. *) + if saved_sp < vm.sp then vm.sp <- saved_sp; push vm callback_result; (try run vm; @@ -1271,7 +1309,9 @@ let trace_run src globals = let code_val2 = frame.closure.vm_code.vc_constants.(idx) in let uv_count = match code_val2 with | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with - | Some (Number n) -> int_of_float n | _ -> 0) + | Some (Integer n) -> n + | Some (Number n) -> int_of_float n + | _ -> 0) | _ -> 0 in let upvalues = Array.init uv_count (fun _ -> let is_local = read_u8 frame in @@ -1392,7 +1432,9 @@ let disassemble (code : vm_code) = if op = 51 && idx < Array.length consts then begin let uv_count = match consts.(idx) with | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with - | Some (Number n) -> int_of_float n | _ -> 0) + | Some (Integer n) -> n + | Some (Number n) -> int_of_float n + | _ -> 0) | _ -> 0 in ip := !ip + uv_count * 2 end diff --git a/hosts/ocaml/lib/sx_vm_ref.ml b/hosts/ocaml/lib/sx_vm_ref.ml index 62e754f1..d8d9b465 100644 --- a/hosts/ocaml/lib/sx_vm_ref.ml +++ b/hosts/ocaml/lib/sx_vm_ref.ml @@ -270,7 +270,9 @@ let vm_create_closure vm_val frame_val code_val = let f = unwrap_frame frame_val in let uv_count = match code_val with | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with - | Some (Number n) -> int_of_float n | _ -> 0) + | Some (Integer n) -> n + | Some (Number n) -> int_of_float n + | _ -> 0) | _ -> 0 in let upvalues = Array.init uv_count (fun _ -> diff --git a/hosts/ocaml/sx_vm_ref.ml b/hosts/ocaml/sx_vm_ref.ml index d7cfd35d..92eedb8f 100644 --- a/hosts/ocaml/sx_vm_ref.ml +++ b/hosts/ocaml/sx_vm_ref.ml @@ -265,7 +265,9 @@ let vm_create_closure vm_val frame_val code_val = let f = unwrap_frame frame_val in let uv_count = match code_val with | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with - | Some (Number n) -> int_of_float n | _ -> 0) + | Some (Integer n) -> n + | Some (Number n) -> int_of_float n + | _ -> 0) | _ -> 0 in let upvalues = Array.init uv_count (fun _ -> 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/conformance.sh b/lib/apl/conformance.sh new file mode 100755 index 00000000..830251e5 --- /dev/null +++ b/lib/apl/conformance.sh @@ -0,0 +1,116 @@ +#!/usr/bin/env bash +# lib/apl/conformance.sh — run APL test suites, emit scoreboard.json + scoreboard.md. + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="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 + +SUITES=(structural operators dfn tradfn valence programs system idioms eval-ops pipeline) + +OUT_JSON="lib/apl/scoreboard.json" +OUT_MD="lib/apl/scoreboard.md" + +run_suite() { + local suite=$1 + local file="lib/apl/tests/${suite}.sx" + local TMP + TMP=$(mktemp) + cat > "$TMP" << EPOCHS +(epoch 1) +(load "spec/stdlib.sx") +(load "lib/r7rs.sx") +(load "lib/apl/runtime.sx") +(load "lib/apl/tokenizer.sx") +(load "lib/apl/parser.sx") +(load "lib/apl/transpile.sx") +(epoch 2) +(eval "(define apl-test-pass 0)") +(eval "(define apl-test-fail 0)") +(eval "(define apl-test (fn (name got expected) (if (= got expected) (set! apl-test-pass (+ apl-test-pass 1)) (set! apl-test-fail (+ apl-test-fail 1)))))") +(epoch 3) +(load "${file}") +(epoch 4) +(eval "(list apl-test-pass apl-test-fail)") +EPOCHS + + local OUTPUT + OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMP" 2>/dev/null) + rm -f "$TMP" + + local LINE + LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}') + if [ -z "$LINE" ]; then + LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \ + | sed -E 's/^\(ok 4 //; s/\)$//') + fi + + local P F + P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/') + F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/') + P=${P:-0} + F=${F:-0} + echo "${P} ${F}" +} + +declare -A SUITE_PASS +declare -A SUITE_FAIL +TOTAL_PASS=0 +TOTAL_FAIL=0 + +echo "Running APL conformance suite..." >&2 +for s in "${SUITES[@]}"; do + read -r p f < <(run_suite "$s") + SUITE_PASS[$s]=$p + SUITE_FAIL[$s]=$f + TOTAL_PASS=$((TOTAL_PASS + p)) + TOTAL_FAIL=$((TOTAL_FAIL + f)) + printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2 +done + +# scoreboard.json +{ + printf '{\n' + printf ' "suites": {\n' + first=1 + for s in "${SUITES[@]}"; do + if [ $first -eq 0 ]; then printf ',\n'; fi + printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}" + first=0 + done + printf '\n },\n' + printf ' "total_pass": %d,\n' "$TOTAL_PASS" + printf ' "total_fail": %d,\n' "$TOTAL_FAIL" + printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))" + printf '}\n' +} > "$OUT_JSON" + +# scoreboard.md +{ + printf '# APL Conformance Scoreboard\n\n' + printf '_Generated by `lib/apl/conformance.sh`_\n\n' + printf '| Suite | Pass | Fail | Total |\n' + printf '|-------|-----:|-----:|------:|\n' + for s in "${SUITES[@]}"; do + p=${SUITE_PASS[$s]} + f=${SUITE_FAIL[$s]} + printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))" + done + printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))" + printf '\n' + printf '## Notes\n\n' + printf '%s\n' '- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.' + printf '%s\n' '- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.' +} > "$OUT_MD" + +echo "Wrote $OUT_JSON and $OUT_MD" >&2 +echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2 + +[ "$TOTAL_FAIL" -eq 0 ] diff --git a/lib/apl/parser.sx b/lib/apl/parser.sx new file mode 100644 index 00000000..43e2f50f --- /dev/null +++ b/lib/apl/parser.sx @@ -0,0 +1,674 @@ +; APL Parser — right-to-left expression parser +; +; Takes a token list (output of apl-tokenize) and produces an AST. +; APL evaluates right-to-left with no precedence among functions. +; Operators bind to the function immediately to their left in the source. +; +; AST node types: +; (:num n) number literal +; (:str s) string literal +; (:vec n1 n2 ...) strand (juxtaposed literals) +; (:name "x") name reference / alpha / omega +; (:assign "x" expr) assignment x←expr +; (:monad fn arg) monadic function call +; (:dyad fn left right) dyadic function call +; (:derived-fn op fn) derived function: f/ f¨ f⍨ +; (:derived-fn2 "." f g) inner product: f.g +; (:outer "∘." fn) outer product: ∘.f +; (:fn-glyph "⍳") function reference +; (:fn-name "foo") named-function reference (dfn variable) +; (:dfn stmt...) {⍺+⍵} anonymous function +; (:guard cond expr) cond:expr guard inside dfn +; (:program stmt...) multi-statement sequence + +; ============================================================ +; Glyph classification sets +; ============================================================ + +(define + apl-parse-op-glyphs + (list "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@")) + +(define + apl-parse-fn-glyphs + (list + "+" + "-" + "×" + "÷" + "*" + "⍟" + "⌈" + "⌊" + "|" + "!" + "?" + "○" + "~" + "<" + "≤" + "=" + "≥" + ">" + "≠" + "≢" + "≡" + "∊" + "∧" + "∨" + "⍱" + "⍲" + "," + "⍪" + "⍴" + "⌽" + "⊖" + "⍉" + "↑" + "↓" + "⊂" + "⊃" + "⊆" + "∪" + "∩" + "⍳" + "⍸" + "⌷" + "⍋" + "⍒" + "⊥" + "⊤" + "⊣" + "⊢" + "⍎" + "⍕")) + +(define apl-quad-fn-names (list "⎕FMT" "⎕←")) + +(define apl-known-fn-names (list)) + +; ============================================================ +; Token accessors +; ============================================================ + +(define + apl-collect-fn-bindings + (fn + (stmt-groups) + (set! apl-known-fn-names (list)) + (for-each + (fn + (toks) + (when + (and + (>= (len toks) 3) + (= (tok-type (nth toks 0)) :name) + (= (tok-type (nth toks 1)) :assign) + (= (tok-type (nth toks 2)) :lbrace)) + (set! + apl-known-fn-names + (cons (tok-val (nth toks 0)) apl-known-fn-names)))) + stmt-groups))) + +(define + apl-parse-op-glyph? + (fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs))) + +(define + apl-parse-fn-glyph? + (fn (v) (some (fn (g) (= g v)) apl-parse-fn-glyphs))) + +(define tok-type (fn (tok) (get tok :type))) + +; ============================================================ +; Collect trailing operators starting at index i +; Returns {:ops (op ...) :end new-i} +; ============================================================ + +(define tok-val (fn (tok) (get tok :value))) + +(define + is-op-tok? + (fn + (tok) + (and (= (tok-type tok) :glyph) (apl-parse-op-glyph? (tok-val tok))))) + +; ============================================================ +; Build a derived-fn node by chaining operators left-to-right +; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+")))) +; ============================================================ + +(define + is-fn-tok? + (fn + (tok) + (or + (and (= (tok-type tok) :glyph) (apl-parse-fn-glyph? (tok-val tok))) + (and + (= (tok-type tok) :name) + (or + (some (fn (q) (= q (tok-val tok))) apl-quad-fn-names) + (some (fn (q) (= q (tok-val tok))) apl-known-fn-names)))))) + +; ============================================================ +; Find matching close bracket/paren/brace +; Returns the index of the matching close token +; ============================================================ + +(define collect-ops (fn (tokens i) (collect-ops-loop tokens i (list)))) + +(define + collect-ops-loop + (fn + (tokens i acc) + (if + (>= i (len tokens)) + {:end i :ops acc} + (let + ((tok (nth tokens i))) + (if + (is-op-tok? tok) + (collect-ops-loop tokens (+ i 1) (append acc (tok-val tok))) + {:end i :ops acc}))))) + +; ============================================================ +; Segment collection: scan tokens left-to-right, building +; a list of {:kind "val"/"fn" :node ast} segments. +; Operators following function glyphs are merged into +; derived-fn nodes during this pass. +; ============================================================ + +(define + build-derived-fn + (fn + (fn-node ops) + (if + (= (len ops) 0) + fn-node + (build-derived-fn (list :derived-fn (first ops) fn-node) (rest ops))))) + +(define + find-matching-close + (fn + (tokens start open-type close-type) + (find-matching-close-loop tokens start open-type close-type 1))) + +; ============================================================ +; Build tree from segment list +; +; The segments are in left-to-right order. +; APL evaluates right-to-left, so the LEFTMOST function is +; the outermost (last-evaluated) node. +; +; Patterns: +; [val] → val node +; [fn val ...] → (:monad fn (build-tree rest)) +; [val fn val ...] → (:dyad fn val (build-tree rest)) +; [val val ...] → (:vec val1 val2 ...) — strand +; ============================================================ + +; Find the index of the first function segment (returns -1 if none) +(define + find-matching-close-loop + (fn + (tokens i open-type close-type depth) + (if + (>= i (len tokens)) + (len tokens) + (let + ((tt (tok-type (nth tokens i)))) + (cond + ((= tt open-type) + (find-matching-close-loop + tokens + (+ i 1) + open-type + close-type + (+ depth 1))) + ((= tt close-type) + (if + (= depth 1) + i + (find-matching-close-loop + tokens + (+ i 1) + open-type + close-type + (- depth 1)))) + (true + (find-matching-close-loop + tokens + (+ i 1) + open-type + close-type + depth))))))) + +(define + collect-segments + (fn (tokens) (collect-segments-loop tokens 0 (list)))) + +; Build an array node from 0..n value segments +; If n=1 → return that segment's node +; If n>1 → return (:vec node1 node2 ...) +(define + collect-segments-loop + (fn + (tokens i acc) + (if + (>= i (len tokens)) + acc + (let + ((tok (nth tokens i)) (n (len tokens))) + (let + ((tt (tok-type tok)) (tv (tok-val tok))) + (cond + ((or (= tt :diamond) (= tt :newline) (= tt :semi)) + (collect-segments-loop tokens (+ i 1) acc)) + ((= tt :num) + (collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :num tv)}))) + ((= tt :str) + (collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)}))) + ((= tt :name) + (cond + ((some (fn (q) (= q tv)) apl-quad-fn-names) + (let + ((op-result (collect-ops tokens (+ i 1)))) + (let + ((ops (get op-result :ops)) + (ni (get op-result :end))) + (let + ((fn-node (build-derived-fn (list :fn-glyph tv) ops))) + (collect-segments-loop + tokens + ni + (append acc {:kind "fn" :node fn-node})))))) + ((some (fn (q) (= q tv)) apl-known-fn-names) + (let + ((op-result (collect-ops tokens (+ i 1)))) + (let + ((ops (get op-result :ops)) + (ni (get op-result :end))) + (let + ((fn-node (build-derived-fn (list :fn-name tv) ops))) + (collect-segments-loop + tokens + ni + (append acc {:kind "fn" :node fn-node})))))) + (else + (let + ((br (maybe-bracket (list :name tv) tokens (+ i 1)))) + (collect-segments-loop + tokens + (nth br 1) + (append acc {:kind "val" :node (nth br 0)})))))) + ((= tt :lparen) + (let + ((end (find-matching-close tokens (+ i 1) :lparen :rparen))) + (let + ((inner-tokens (slice tokens (+ i 1) end)) + (after (+ end 1))) + (let + ((inner-segs (collect-segments inner-tokens))) + (if + (and + (>= (len inner-segs) 2) + (every? (fn (s) (= (get s :kind) "fn")) inner-segs)) + (let + ((train-node (cons :train (map (fn (s) (get s :node)) inner-segs)))) + (collect-segments-loop + tokens + after + (append acc {:kind "fn" :node train-node}))) + (let + ((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after))) + (collect-segments-loop + tokens + (nth br 1) + (append acc {:kind "val" :node (nth br 0)})))))))) + ((= tt :lbrace) + (let + ((end (find-matching-close tokens (+ i 1) :lbrace :rbrace))) + (let + ((inner-tokens (slice tokens (+ i 1) end)) + (after (+ end 1))) + (collect-segments-loop tokens after (append acc {:kind "fn" :node (parse-dfn inner-tokens)}))))) + ((= tt :glyph) + (cond + ((or (= tv "⍺") (= tv "⍵")) + (collect-segments-loop + tokens + (+ i 1) + (append acc {:kind "val" :node (list :name tv)}))) + ((= tv "∇") + (collect-segments-loop + tokens + (+ i 1) + (append acc {:kind "fn" :node (list :fn-glyph "∇")}))) + ((and (= tv "∘") (< (+ i 1) n) (= (tok-val (nth tokens (+ i 1))) ".")) + (if + (and (< (+ i 2) n) (is-fn-tok? (nth tokens (+ i 2)))) + (let + ((fn-tv (tok-val (nth tokens (+ i 2))))) + (let + ((op-result (collect-ops tokens (+ i 3)))) + (let + ((ops (get op-result :ops)) + (ni (get op-result :end))) + (let + ((fn-node (build-derived-fn (list :fn-glyph fn-tv) ops))) + (collect-segments-loop + tokens + ni + (append acc {:kind "fn" :node (list :outer "∘." fn-node)})))))) + (collect-segments-loop tokens (+ i 1) acc))) + ((apl-parse-fn-glyph? tv) + (let + ((op-result (collect-ops tokens (+ i 1)))) + (let + ((ops (get op-result :ops)) + (ni (get op-result :end))) + (if + (and + (= (len ops) 1) + (= (first ops) ".") + (< ni n) + (is-fn-tok? (nth tokens ni))) + (let + ((g-tv (tok-val (nth tokens ni)))) + (let + ((op-result2 (collect-ops tokens (+ ni 1)))) + (let + ((ops2 (get op-result2 :ops)) + (ni2 (get op-result2 :end))) + (let + ((g-node (build-derived-fn (list :fn-glyph g-tv) ops2))) + (collect-segments-loop + tokens + ni2 + (append acc {:kind "fn" :node (list :derived-fn2 "." (list :fn-glyph tv) g-node)})))))) + (let + ((fn-node (build-derived-fn (list :fn-glyph tv) ops))) + (collect-segments-loop + tokens + ni + (append acc {:kind "fn" :node fn-node}))))))) + ((apl-parse-op-glyph? tv) + (collect-segments-loop tokens (+ i 1) acc)) + (true (collect-segments-loop tokens (+ i 1) acc)))) + (true (collect-segments-loop tokens (+ i 1) acc)))))))) + +(define find-first-fn (fn (segs) (find-first-fn-loop segs 0))) + + +; ============================================================ +; Split token list on statement separators (diamond / newline) +; Only splits at depth 0 (ignores separators inside { } or ( ) ) +; ============================================================ + +(define + find-first-fn-loop + (fn + (segs i) + (if + (>= i (len segs)) + -1 + (if + (= (get (nth segs i) :kind) "fn") + i + (find-first-fn-loop segs (+ i 1)))))) + +(define + segs-to-array + (fn + (segs) + (if + (= (len segs) 1) + (get (first segs) :node) + (cons :vec (map (fn (s) (get s :node)) segs))))) + +; ============================================================ +; Parse a dfn body (tokens between { and }) +; Handles guard expressions: cond : expr +; ============================================================ + +(define + build-tree + (fn + (segs) + (cond + ((= (len segs) 0) nil) + ((= (len segs) 1) (get (first segs) :node)) + ((every? (fn (s) (= (get s :kind) "val")) segs) + (segs-to-array segs)) + (true + (let + ((fn-idx (find-first-fn segs))) + (cond + ((= fn-idx -1) (segs-to-array segs)) + ((= fn-idx 0) + (list + :monad (get (first segs) :node) + (build-tree (rest segs)))) + (true + (let + ((left-segs (slice segs 0 fn-idx)) + (fn-seg (nth segs fn-idx)) + (right-segs (slice segs (+ fn-idx 1)))) + (list + :dyad (get fn-seg :node) + (segs-to-array left-segs) + (build-tree right-segs)))))))))) + +(define + split-statements + (fn (tokens) (split-statements-loop tokens (list) (list) 0))) + +(define + split-statements-loop + (fn + (tokens current-stmt acc depth) + (if + (= (len tokens) 0) + (if (> (len current-stmt) 0) (append acc (list current-stmt)) acc) + (let + ((tok (first tokens)) + (rest-toks (rest tokens)) + (tt (tok-type (first tokens)))) + (cond + ((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket)) + (split-statements-loop + rest-toks + (append current-stmt tok) + acc + (+ depth 1))) + ((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket)) + (split-statements-loop + rest-toks + (append current-stmt tok) + acc + (- depth 1))) + ((and (> depth 0) (or (= tt :diamond) (= tt :newline))) + (split-statements-loop + rest-toks + (append current-stmt tok) + acc + depth)) + ((and (= depth 0) (or (= tt :diamond) (= tt :newline))) + (if + (> (len current-stmt) 0) + (split-statements-loop + rest-toks + (list) + (append acc (list current-stmt)) + depth) + (split-statements-loop rest-toks (list) acc depth))) + (true + (split-statements-loop + rest-toks + (append current-stmt tok) + acc + depth))))))) + +(define + parse-dfn + (fn + (tokens) + (let + ((stmt-groups (split-statements tokens))) + (let ((stmts (map parse-dfn-stmt stmt-groups))) (cons :dfn stmts))))) + +; ============================================================ +; Parse a single statement (assignment or expression) +; ============================================================ + +(define + parse-dfn-stmt + (fn + (tokens) + (let + ((colon-idx (find-top-level-colon tokens 0))) + (if + (>= colon-idx 0) + (let + ((cond-tokens (slice tokens 0 colon-idx)) + (body-tokens (slice tokens (+ colon-idx 1)))) + (list + :guard (parse-apl-expr cond-tokens) + (parse-apl-expr body-tokens))) + (parse-stmt tokens))))) + +; ============================================================ +; Parse an expression from a flat token list +; ============================================================ + +(define + find-top-level-colon + (fn (tokens i) (find-top-level-colon-loop tokens i 0))) + +; ============================================================ +; Main entry point +; parse-apl: string → AST +; ============================================================ + +(define + find-top-level-colon-loop + (fn + (tokens i depth) + (if + (>= i (len tokens)) + -1 + (let + ((tok (nth tokens i)) (tt (tok-type (nth tokens i)))) + (cond + ((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket)) + (find-top-level-colon-loop tokens (+ i 1) (+ depth 1))) + ((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket)) + (find-top-level-colon-loop tokens (+ i 1) (- depth 1))) + ((and (= tt :colon) (= depth 0)) i) + (true (find-top-level-colon-loop tokens (+ i 1) depth))))))) + +(define + parse-stmt + (fn + (tokens) + (if + (and + (>= (len tokens) 2) + (= (tok-type (nth tokens 0)) :name) + (= (tok-type (nth tokens 1)) :assign)) + (list + :assign (tok-val (nth tokens 0)) + (parse-apl-expr (slice tokens 2))) + (parse-apl-expr tokens)))) + +(define + parse-apl-expr + (fn + (tokens) + (let + ((segs (collect-segments tokens))) + (if (= (len segs) 0) nil (build-tree segs))))) + +(define + parse-apl + (fn + (src) + (let + ((tokens (apl-tokenize src))) + (let + ((stmt-groups (split-statements tokens))) + (begin + (apl-collect-fn-bindings stmt-groups) + (if + (= (len stmt-groups) 0) + nil + (if + (= (len stmt-groups) 1) + (parse-stmt (first stmt-groups)) + (cons :program (map parse-stmt stmt-groups))))))))) + +(define + split-bracket-loop + (fn + (tokens current acc depth) + (if + (= (len tokens) 0) + (append acc (list current)) + (let + ((tok (first tokens)) (more (rest tokens))) + (let + ((tt (tok-type tok))) + (cond + ((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket)) + (split-bracket-loop + more + (append current (list tok)) + acc + (+ depth 1))) + ((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket)) + (split-bracket-loop + more + (append current (list tok)) + acc + (- depth 1))) + ((and (= tt :semi) (= depth 0)) + (split-bracket-loop + more + (list) + (append acc (list current)) + depth)) + (else + (split-bracket-loop more (append current (list tok)) acc depth)))))))) + +(define + split-bracket-content + (fn (tokens) (split-bracket-loop tokens (list) (list) 0))) + +(define + maybe-bracket + (fn + (val-node tokens after) + (if + (and + (< after (len tokens)) + (= (tok-type (nth tokens after)) :lbracket)) + (let + ((end (find-matching-close tokens (+ after 1) :lbracket :rbracket))) + (let + ((inner-tokens (slice tokens (+ after 1) end)) + (next-after (+ end 1))) + (let + ((sections (split-bracket-content inner-tokens))) + (if + (= (len sections) 1) + (let + ((idx-expr (parse-apl-expr inner-tokens))) + (let + ((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node))) + (maybe-bracket indexed tokens next-after))) + (let + ((axis-exprs (map (fn (toks) (if (= (len toks) 0) :all (parse-apl-expr toks))) sections))) + (let + ((indexed (cons :bracket (cons val-node axis-exprs)))) + (maybe-bracket indexed tokens next-after))))))) + (list val-node after)))) diff --git a/lib/apl/runtime.sx b/lib/apl/runtime.sx new file mode 100644 index 00000000..07652f77 --- /dev/null +++ b/lib/apl/runtime.sx @@ -0,0 +1,1375 @@ +; APL Runtime — array model + scalar primitives +; +; Array = SX dict {:shape (d1 d2 ...) :ravel (v1 v2 ...)} +; Scalar: rank 0, shape (), one element in ravel +; Vector: rank 1, shape (n), n elements in ravel +; Matrix: rank 2, shape (r c), r*c elements in ravel + +; ============================================================ +; Array constructors +; ============================================================ + +(define make-array (fn (shape ravel) {:ravel ravel :shape shape})) + +(define apl-scalar (fn (v) {:ravel (list v) :shape (list)})) + +(define apl-vector (fn (elems) {:ravel elems :shape (list (len elems))})) + +; enclose — wrap any value in a rank-0 box +(define enclose (fn (v) (apl-scalar v))) + +; disclose — unwrap rank-0 box, returning the first element +(define disclose (fn (arr) (first (get arr :ravel)))) + +; ============================================================ +; Array accessors +; ============================================================ + +(define array-rank (fn (arr) (len (get arr :shape)))) + +(define scalar? (fn (arr) (= (len (get arr :shape)) 0))) + +(define array-ref (fn (arr i) (nth (get arr :ravel) i))) + +; ============================================================ +; System variables +; ============================================================ + +(define apl-io 1) + +; ============================================================ +; Broadcast engine +; ============================================================ + +(define + broadcast-monadic + (fn (f arr) (make-array (get arr :shape) (map f (get arr :ravel))))) + +(define + broadcast-dyadic + (fn + (f a b) + (cond + ((and (scalar? a) (scalar? b)) + (apl-scalar (f (first (get a :ravel)) (first (get b :ravel))))) + ((scalar? a) + (let + ((sv (first (get a :ravel)))) + (make-array + (get b :shape) + (map (fn (x) (f sv x)) (get b :ravel))))) + ((scalar? b) + (let + ((sv (first (get b :ravel)))) + (make-array + (get a :shape) + (map (fn (x) (f x sv)) (get a :ravel))))) + (else + (if + (equal? (get a :shape) (get b :shape)) + (make-array (get a :shape) (map f (get a :ravel) (get b :ravel))) + (error "length error: shape mismatch")))))) + +; ============================================================ +; Arithmetic primitives +; ============================================================ + +; Monadic + : identity +(define apl-plus-m (fn (a) (broadcast-monadic (fn (x) x) a))) + +; Dyadic + +(define apl-add (fn (a b) (broadcast-dyadic (fn (x y) (+ x y)) a b))) + +; Monadic - : negate +(define apl-neg-m (fn (a) (broadcast-monadic (fn (x) (- 0 x)) a))) + +; Dyadic - +(define apl-sub (fn (a b) (broadcast-dyadic (fn (x y) (- x y)) a b))) + +; Monadic × : signum +(define + apl-signum + (fn + (a) + (broadcast-monadic + (fn (x) (cond ((> x 0) 1) ((< x 0) -1) (else 0))) + a))) + +; Dyadic × +(define apl-mul (fn (a b) (broadcast-dyadic (fn (x y) (* x y)) a b))) + +; Monadic ÷ : reciprocal +(define apl-recip (fn (a) (broadcast-monadic (fn (x) (/ 1 x)) a))) + +; Dyadic ÷ +(define apl-div (fn (a b) (broadcast-dyadic (fn (x y) (/ x y)) a b))) + +; Monadic ⌈ : ceiling +(define apl-ceil (fn (a) (broadcast-monadic (fn (x) (ceil x)) a))) + +; Dyadic ⌈ : max +(define + apl-max + (fn (a b) (broadcast-dyadic (fn (x y) (if (>= x y) x y)) a b))) + +; Monadic ⌊ : floor +(define apl-floor (fn (a) (broadcast-monadic (fn (x) (floor x)) a))) + +; Dyadic ⌊ : min +(define + apl-min + (fn (a b) (broadcast-dyadic (fn (x y) (if (<= x y) x y)) a b))) + +; Monadic * : e^x +(define apl-exp (fn (a) (broadcast-monadic (fn (x) (exp x)) a))) + +; Dyadic * : power +(define apl-pow (fn (a b) (broadcast-dyadic (fn (x y) (pow x y)) a b))) + +; Monadic ⍟ : natural log +(define apl-ln (fn (a) (broadcast-monadic (fn (x) (log x)) a))) + +; Dyadic ⍟ : log base (a⍟b = log base a of b) +(define + apl-log + (fn (a b) (broadcast-dyadic (fn (x y) (/ (log y) (log x))) a b))) + +; Monadic | : absolute value +(define + apl-abs + (fn (a) (broadcast-monadic (fn (x) (if (< x 0) (- 0 x) x)) a))) + +; Dyadic | : modulo (a|b = b mod a) +(define + apl-mod + (fn + (a b) + (broadcast-dyadic + (fn (x y) (if (= x 0) y (- y (* x (floor (/ y x)))))) + a + b))) + +; Monadic ! : factorial +(define + apl-fact + (fn + (a) + (broadcast-monadic + (fn + (n) + (let + ((loop nil)) + (begin + (set! + loop + (fn (i acc) (if (> i n) acc (loop (+ i 1) (* acc i))))) + (loop 1 1)))) + a))) + +; Dyadic ! : binomial coefficient n!k (a=n, b=k => a choose b) +(define + apl-binomial + (fn + (a b) + (broadcast-dyadic + (fn + (n k) + (let + ((loop nil)) + (begin + (set! + loop + (fn + (i num den) + (if + (> i k) + (/ num den) + (loop (+ i 1) (* num (- (+ n 1) i)) (* den i))))) + (loop 1 1 1)))) + a + b))) + +; Monadic ○ : pi times x +(define + apl-pi-times + (fn (a) (broadcast-monadic (fn (x) (* 3.14159 x)) a))) + +; Dyadic ○ : trig functions (a○b, a=code, b=value) +(define + apl-trig + (fn + (a b) + (broadcast-dyadic + (fn + (n x) + (cond + ((= n 0) (pow (- 1 (* x x)) 0.5)) + ((= n 1) (sin x)) + ((= n 2) (cos x)) + ((= n 3) (tan x)) + ((= n -1) (asin x)) + ((= n -2) (acos x)) + ((= n -3) (atan x)) + (else (error "circle: unsupported trig code")))) + a + b))) + +; ============================================================ +; Comparison primitives (return 0 or 1) +; ============================================================ + +(define + apl-lt + (fn (a b) (broadcast-dyadic (fn (x y) (if (< x y) 1 0)) a b))) + +(define + apl-le + (fn (a b) (broadcast-dyadic (fn (x y) (if (<= x y) 1 0)) a b))) + +(define + apl-eq + (fn (a b) (broadcast-dyadic (fn (x y) (if (= x y) 1 0)) a b))) + +(define + apl-ge + (fn (a b) (broadcast-dyadic (fn (x y) (if (>= x y) 1 0)) a b))) + +(define + apl-gt + (fn (a b) (broadcast-dyadic (fn (x y) (if (> x y) 1 0)) a b))) + +(define + apl-ne + (fn (a b) (broadcast-dyadic (fn (x y) (if (= x y) 0 1)) a b))) + +; ============================================================ +; Logical primitives +; ============================================================ + +; Monadic ~ : logical not +(define + apl-not + (fn (a) (broadcast-monadic (fn (x) (if (= x 0) 1 0)) a))) + +; Dyadic ∧ : logical and +(define + apl-and + (fn + (a b) + (broadcast-dyadic + (fn (x y) (if (and (not (= x 0)) (not (= y 0))) 1 0)) + a + b))) + +; Dyadic ∨ : logical or +(define + apl-or + (fn + (a b) + (broadcast-dyadic + (fn (x y) (if (or (not (= x 0)) (not (= y 0))) 1 0)) + a + b))) + +; Dyadic ⍱ : logical nor +(define + apl-nor + (fn + (a b) + (broadcast-dyadic + (fn (x y) (if (or (not (= x 0)) (not (= y 0))) 0 1)) + a + b))) + +; Dyadic ⍲ : logical nand +(define + apl-nand + (fn + (a b) + (broadcast-dyadic + (fn (x y) (if (and (not (= x 0)) (not (= y 0))) 0 1)) + a + b))) + +; ============================================================ +; Shape primitives +; ============================================================ + +; Monadic ⍴ : shape — returns shape as a vector array +(define apl-shape (fn (arr) (apl-vector (get arr :shape)))) + +; Monadic , : ravel — returns a rank-1 vector of all elements +(define apl-ravel (fn (arr) (apl-vector (get arr :ravel)))) + +; Monadic ≢ : tally — first dimension (1 for scalar) +(define + apl-tally + (fn + (arr) + (if + (scalar? arr) + (apl-scalar 1) + (apl-scalar (first (get arr :shape)))))) + +; Monadic ≡ : depth +; simple number/string value → 0 +; array containing only non-arrays → 0 +; array containing arrays → 1 + max depth of elements +(define + apl-depth + (fn + (arr) + (define item-depth nil) + (set! + item-depth + (fn + (v) + (if + (and + (dict? v) + (not (= nil (get v :shape nil))) + (not (= nil (get v :ravel nil)))) + (+ 1 (first (get (apl-depth v) :ravel))) + 0))) + (let + ((depths (map item-depth (get arr :ravel)))) + (apl-scalar (reduce (fn (a b) (if (> a b) a b)) 0 depths))))) + +; Monadic ⍳ : iota — vector 1..n (with ⎕IO=1) +(define + apl-iota + (fn + (n-arr) + (let + ((n (first (get n-arr :ravel))) (build nil)) + (begin + (set! + build + (fn (i acc) (if (< i 1) acc (build (- i 1) (cons i acc))))) + (apl-vector (build n (list))))))) + +(define + apl-strides + (fn + (shape) + (map + (fn (i) (reduce * 1 (drop shape (+ i 1)))) + (range 0 (len shape))))) + +(define + apl-flat->multi + (fn + (flat shape strides) + (map + (fn (i) (mod (floor (/ flat (nth strides i))) (nth shape i))) + (range 0 (len shape))))) + +(define + apl-multi->flat + (fn (coords strides) (reduce + 0 (map * coords strides)))) + +(define + apl-reshape + (fn + (shape-arr data-arr) + (let + ((new-shape (if (scalar? shape-arr) (list (disclose shape-arr)) (get shape-arr :ravel))) + (src-ravel + (if + (scalar? data-arr) + (list (disclose data-arr)) + (get data-arr :ravel)))) + (let + ((new-size (reduce * 1 new-shape)) (src-len (len src-ravel))) + (let + ((new-ravel (if (= new-size 0) (list) (if (= src-len 0) (map (fn (i) 0) (range 0 new-size)) (map (fn (i) (nth src-ravel (mod i src-len))) (range 0 new-size)))))) + (make-array new-shape new-ravel)))))) + +(define + apl-transpose + (fn + (arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (if + (< (len shape) 2) + arr + (let + ((new-shape (reverse shape)) (strides (apl-strides shape))) + (let + ((new-strides (apl-strides new-shape)) (new-size (len ravel))) + (make-array + new-shape + (map + (fn + (new-flat) + (let + ((new-coords (apl-flat->multi new-flat new-shape new-strides))) + (nth + ravel + (apl-multi->flat (reverse new-coords) strides)))) + (range 0 new-size))))))))) + +(define + apl-transpose-dyadic + (fn + (perm-arr data-arr) + (let + ((perm (map (fn (p) (- p apl-io)) (get perm-arr :ravel))) + (shape (get data-arr :shape)) + (ravel (get data-arr :ravel))) + (let + ((new-shape (map (fn (k) (nth shape k)) perm)) + (strides (apl-strides shape))) + (let + ((inv-perm (map (fn (j) (index-of perm j)) (range 0 (len perm)))) + (new-strides (apl-strides new-shape)) + (new-size (len ravel))) + (make-array + new-shape + (map + (fn + (new-flat) + (let + ((new-coords (apl-flat->multi new-flat new-shape new-strides))) + (let + ((old-coords (map (fn (i) (nth new-coords (nth inv-perm i))) (range 0 (len shape))))) + (nth ravel (apl-multi->flat old-coords strides))))) + (range 0 new-size)))))))) + +(define apl-safe-mod (fn (a m) (mod (+ (mod a m) m) m))) + +(define + apl-take + (fn + (n-arr data-arr) + (let + ((old-shape (get data-arr :shape)) + (old-ravel (get data-arr :ravel)) + (ns + (if (scalar? n-arr) (list (disclose n-arr)) (get n-arr :ravel)))) + (let + ((new-shape (map abs ns)) (old-strides (apl-strides old-shape))) + (let + ((new-size (reduce * 1 new-shape)) + (new-strides (apl-strides new-shape))) + (make-array + new-shape + (map + (fn + (new-flat) + (let + ((new-coords (apl-flat->multi new-flat new-shape new-strides))) + (let + ((old-coords (map (fn (i) (let ((ni (nth ns i)) (nc (nth new-coords i)) (od (nth old-shape i))) (if (>= ni 0) nc (+ (- od (- ni)) nc)))) (range 0 (len ns))))) + (if + (every? + (fn + (i) + (and + (>= (nth old-coords i) 0) + (< (nth old-coords i) (nth old-shape i)))) + (range 0 (len old-coords))) + (nth old-ravel (apl-multi->flat old-coords old-strides)) + 0)))) + (range 0 new-size)))))))) + +(define + apl-drop + (fn + (n-arr data-arr) + (let + ((old-shape (get data-arr :shape)) + (old-ravel (get data-arr :ravel)) + (ns + (if (scalar? n-arr) (list (disclose n-arr)) (get n-arr :ravel)))) + (let + ((new-shape (map (fn (i) (let ((ni (nth ns i)) (od (nth old-shape i))) (let ((d (if (>= ni 0) (- od ni) (+ od ni)))) (if (> d 0) d 0)))) (range 0 (len ns)))) + (offsets + (map + (fn (i) (let ((ni (nth ns i))) (if (>= ni 0) ni 0))) + (range 0 (len ns)))) + (old-strides (apl-strides old-shape))) + (let + ((new-size (reduce * 1 new-shape)) + (new-strides (apl-strides new-shape))) + (make-array + new-shape + (map + (fn + (new-flat) + (let + ((new-coords (apl-flat->multi new-flat new-shape new-strides))) + (let + ((old-coords (map (fn (i) (+ (nth new-coords i) (nth offsets i))) (range 0 (len ns))))) + (nth old-ravel (apl-multi->flat old-coords old-strides))))) + (range 0 new-size)))))))) + +(define + apl-reverse + (fn + (arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (if + (= (len shape) 0) + arr + (let + ((last-dim (last shape)) (n (len ravel))) + (make-array + shape + (map + (fn + (flat) + (let + ((c-last (mod flat last-dim))) + (nth ravel (+ flat (- last-dim 1) (* -2 c-last))))) + (range 0 n)))))))) + +(define + apl-reverse-first + (fn + (arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (if + (= (len shape) 0) + arr + (let + ((first-dim (first shape)) + (first-stride (reduce * 1 (rest shape))) + (n (len ravel))) + (make-array + shape + (map + (fn + (flat) + (let + ((row (floor (/ flat first-stride)))) + (let + ((old-row (- first-dim 1 row))) + (nth + ravel + (+ (* old-row first-stride) (mod flat first-stride)))))) + (range 0 n)))))))) + +(define + apl-rotate-first + (fn + (n-arr data-arr) + (let + ((shape (get data-arr :shape)) + (ravel (get data-arr :ravel)) + (rot (disclose n-arr))) + (if + (= (len shape) 0) + data-arr + (let + ((first-dim (first shape)) + (first-stride (reduce * 1 (rest shape))) + (n (len ravel))) + (make-array + shape + (map + (fn + (flat) + (let + ((row (floor (/ flat first-stride)))) + (let + ((old-row (apl-safe-mod (+ row rot) first-dim))) + (nth + ravel + (+ (* old-row first-stride) (mod flat first-stride)))))) + (range 0 n)))))))) + +(define + apl-rotate + (fn + (n-arr data-arr) + (let + ((shape (get data-arr :shape)) + (ravel (get data-arr :ravel)) + (rot (disclose n-arr))) + (if + (= (len shape) 0) + data-arr + (let + ((last-dim (last shape)) (n (len ravel))) + (make-array + shape + (map + (fn + (flat) + (let + ((c-last (mod flat last-dim))) + (let + ((old-c-last (apl-safe-mod (+ c-last rot) last-dim))) + (nth ravel (+ flat (- old-c-last c-last)))))) + (range 0 n)))))))) + +(define + apl-catenate + (fn + (a b) + (let + ((a-s (if (scalar? a) (list 1) (get a :shape))) + (b-s (if (scalar? b) (list 1) (get b :shape))) + (a-r (get a :ravel)) + (b-r (get b :ravel))) + (let + ((a-last (last a-s)) (prefix (take a-s (- (len a-s) 1)))) + (let + ((new-shape (append prefix (list (+ a-last (last b-s))))) + (a-strides (apl-strides a-s)) + (b-strides (apl-strides b-s))) + (let + ((new-size (reduce * 1 new-shape)) + (new-strides (apl-strides new-shape))) + (make-array + new-shape + (map + (fn + (new-flat) + (let + ((new-coords (apl-flat->multi new-flat new-shape new-strides))) + (let + ((last-c (last new-coords)) + (prefix-c (take new-coords (- (len new-coords) 1)))) + (if + (< last-c a-last) + (nth + a-r + (apl-multi->flat + (append prefix-c (list last-c)) + a-strides)) + (nth + b-r + (apl-multi->flat + (append prefix-c (list (- last-c a-last))) + b-strides)))))) + (range 0 new-size))))))))) + +(define + apl-catenate-first + (fn + (a b) + (let + ((a-s (if (scalar? a) (list 1) (get a :shape))) + (b-s (if (scalar? b) (list 1) (get b :shape))) + (a-r (get a :ravel)) + (b-r (get b :ravel))) + (make-array + (cons (+ (first a-s) (first b-s)) (rest a-s)) + (append a-r b-r))))) + +(define + apl-squad + (fn + (idx-arr data-arr) + (let + ((shape (get data-arr :shape)) + (ravel (get data-arr :ravel)) + (strides (apl-strides (get data-arr :shape)))) + (let + ((idxs (if (scalar? idx-arr) (list (disclose idx-arr)) (get idx-arr :ravel)))) + (let + ((k (len idxs)) (rank (len shape))) + (let + ((adj (map (fn (i) (- i apl-io)) idxs))) + (if + (= k rank) + (apl-scalar (nth ravel (apl-multi->flat adj strides))) + (let + ((remaining-shape (drop shape k)) + (start (apl-multi->flat adj (take strides k))) + (slice-size (reduce * 1 (drop shape k)))) + (make-array + remaining-shape + (map + (fn (j) (nth ravel (+ start j))) + (range 0 slice-size))))))))))) + +(define + apl-grade + (fn + (arr ascending) + (let + ((ravel (get arr :ravel)) (n (len (get arr :ravel)))) + (let + ((pairs (map (fn (i) (list (nth ravel i) (+ i apl-io))) (range 0 n)))) + (define ins nil) + (set! + ins + (fn + (x sorted) + (if + (= (len sorted) 0) + (list x) + (let + ((xv (first x)) + (xi (nth x 1)) + (hd (first sorted)) + (sv (first hd)) + (si (nth hd 1))) + (if + (if + ascending + (or (< xv sv) (and (= xv sv) (< xi si))) + (or (> xv sv) (and (= xv sv) (< xi si)))) + (cons x sorted) + (cons hd (ins x (rest sorted)))))))) + (define isort nil) + (set! + isort + (fn + (lst) + (if + (= (len lst) 0) + (list) + (ins (first lst) (isort (rest lst)))))) + (make-array (list n) (map (fn (p) (nth p 1)) (isort pairs))))))) + +(define apl-grade-up (fn (arr) (apl-grade arr true))) + +(define apl-grade-down (fn (arr) (apl-grade arr false))) + +(define apl-enclose (fn (arr) (apl-scalar arr))) + +(define + apl-disclose + (fn + (arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (if + (= (len shape) 0) + (let + ((inner (first ravel))) + (if (= (type-of inner) "dict") inner (apl-scalar inner))) + (if + (= (len shape) 1) + (apl-scalar (first ravel)) + (let + ((inner-shape (rest shape)) + (inner-size (reduce * 1 (rest shape)))) + (make-array inner-shape (take ravel inner-size)))))))) + +(define + apl-member + (fn + (a b) + (let + ((a-ravel (if (scalar? a) (list (disclose a)) (get a :ravel))) + (b-ravel (if (scalar? b) (list (disclose b)) (get b :ravel))) + (a-shape (get a :shape))) + (make-array + a-shape + (map (fn (x) (if (index-of b-ravel x) 1 0)) a-ravel))))) + +(define + apl-index-of + (fn + (v w) + (let + ((v-ravel (if (scalar? v) (list (disclose v)) (get v :ravel))) + (w-ravel (if (scalar? w) (list (disclose w)) (get w :ravel))) + (w-shape (get w :shape)) + (n (len (if (scalar? v) (list (disclose v)) (get v :ravel))))) + (make-array + w-shape + (map + (fn + (x) + (let + ((i (index-of v-ravel x))) + (if i (+ i apl-io) (+ n apl-io)))) + w-ravel))))) + +(define + apl-without + (fn + (a b) + (let + ((a-ravel (if (scalar? a) (list (disclose a)) (get a :ravel))) + (b-ravel (if (scalar? b) (list (disclose b)) (get b :ravel)))) + (let + ((result (filter (fn (x) (not (index-of b-ravel x))) a-ravel))) + (make-array (list (len result)) result))))) + +(define + apl-compress + (fn + (mask arr) + (let + ((mask-ravel (get mask :ravel)) (arr-ravel (get arr :ravel))) + (let + ((kept (filter (fn (i) (not (= 0 (nth mask-ravel i)))) (range 0 (len arr-ravel))))) + (let + ((picked (map (fn (i) (nth arr-ravel i)) kept))) + (make-array (list (len picked)) picked)))))) + +(define + apl-primes + (fn + (n) + (let + ((a (apl-iota (apl-scalar n)))) + (let + ((mod-table (apl-outer apl-mod a a))) + (let + ((zero-mask (apl-eq (apl-scalar 0) mod-table))) + (let + ((divisor-counts (apl-reduce-first apl-add zero-mask))) + (let + ((prime-mask (apl-eq (apl-scalar 2) divisor-counts))) + (apl-compress prime-mask a)))))))) + +(define + apl-life-step + (fn + (board) + (let + ((zero-board (apl-mul board (apl-scalar 0)))) + (let + ((sum-board (reduce (fn (acc dr) (reduce (fn (acc2 dc) (apl-add acc2 (apl-rotate-first (apl-scalar dr) (apl-rotate (apl-scalar dc) board)))) acc (list -1 0 1))) zero-board (list -1 0 1)))) + (apl-or + (apl-eq sum-board (apl-scalar 3)) + (apl-and board (apl-eq sum-board (apl-scalar 4)))))))) + +(define + apl-mandelbrot-step + (fn + (cs z counts alive iters-left) + (if + (= iters-left 0) + counts + (let + ((still-alive (apl-and alive (apl-le (apl-mul z z) (apl-scalar 4))))) + (let + ((new-z (apl-mul still-alive (apl-add (apl-mul z z) cs)))) + (let + ((new-counts (apl-add counts still-alive))) + (apl-mandelbrot-step + cs + new-z + new-counts + still-alive + (- iters-left 1)))))))) + +(define + apl-mandelbrot-1d + (fn + (cs max-iter) + (let + ((zero (apl-mul cs (apl-scalar 0))) + (ones (apl-add (apl-mul cs (apl-scalar 0)) (apl-scalar 1)))) + (apl-mandelbrot-step cs zero zero ones max-iter)))) + +(define + apl-insert-everywhere + (fn + (x lst) + (map + (fn (i) (append (take lst i) (cons x (drop lst i)))) + (range 0 (+ (len lst) 1))))) + +(define + apl-permutations + (fn + (n) + (if + (<= n 1) + (list (list 1)) + (let + ((sub (apl-permutations (- n 1)))) + (reduce + (fn (acc p) (append (apl-insert-everywhere n p) acc)) + (list) + sub))))) + +(define + apl-queens-no-conflict? + (fn + (perm i j n) + (cond + ((>= i n) true) + ((>= j n) (apl-queens-no-conflict? perm (+ i 1) (+ i 2) n)) + ((= (abs (- i j)) (abs (- (nth perm i) (nth perm j)))) false) + (else (apl-queens-no-conflict? perm i (+ j 1) n))))) + +(define + apl-queens-valid? + (fn (perm) (apl-queens-no-conflict? perm 0 1 (len perm)))) + +(define + apl-queens + (fn + (n) + (apl-scalar (len (filter apl-queens-valid? (apl-permutations n)))))) + +(define + apl-quicksort + (fn + (arr) + (let + ((ravel (get arr :ravel))) + (if + (<= (len ravel) 1) + arr + (let + ((pivot (apl-scalar (first ravel)))) + (let + ((less (apl-quicksort (apl-compress (apl-lt arr pivot) arr))) + (eq (apl-compress (apl-eq arr pivot) arr)) + (greater + (apl-quicksort (apl-compress (apl-gt arr pivot) arr)))) + (apl-catenate less (apl-catenate eq greater)))))))) + +(define apl-quad-io (fn () (apl-scalar apl-io))) + +(define apl-quad-ml (fn () (apl-scalar 1))) + +(define apl-quad-fr (fn () (apl-scalar 1248))) + +(define apl-quad-ts (fn () (make-array (list 7) (list 1970 1 1 0 0 0 0)))) + +(define apl-quad-fmt-scalar (fn (v) (str v))) + +(define + apl-quad-fmt-vector + (fn + (ravel) + (if + (= (len ravel) 0) + "" + (reduce + (fn (acc x) (str acc " " x)) + (str (first ravel)) + (rest ravel))))) + +(define + apl-quad-fmt + (fn + (arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (cond + ((= (len shape) 0) (apl-quad-fmt-scalar (first ravel))) + ((= (len shape) 1) (apl-quad-fmt-vector ravel)) + ((= (len shape) 2) + (let + ((rows (first shape)) (cols (last shape))) + (reduce + (fn + (acc r) + (let + ((row-ravel (map (fn (j) (nth ravel (+ (* r cols) j))) (range 0 cols)))) + (str acc (apl-quad-fmt-vector row-ravel) "\n"))) + "" + (range 0 rows)))) + (else (apl-quad-fmt-vector ravel)))))) + +(define apl-quad-print (fn (arr) arr)) + +(define apl-throw (fn (code msg) (raise (list "apl-error" code msg)))) + +(define + apl-trap-matches? + (fn + (codes e) + (and + (list? e) + (>= (len e) 2) + (= (first e) "apl-error") + (or + (some (fn (c) (= c 0)) codes) + (some (fn (c) (= c (nth e 1))) codes))))) + +(define + apl-cartesian + (fn + (lists) + (if + (= (len lists) 0) + (list (list)) + (let + ((rest-prods (apl-cartesian (rest lists)))) + (reduce + (fn (acc x) (append acc (map (fn (p) (cons x p)) rest-prods))) + (list) + (first lists)))))) + +(define + apl-bracket-multi + (fn + (axes arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (let + ((rank (len shape)) (strides (apl-strides shape))) + (let + ((axis-info (map (fn (i) (let ((a (nth axes i))) (cond ((= a nil) {:idxs (range 0 (nth shape i)) :scalar? false}) ((= (len (get a :shape)) 0) {:idxs (list (- (first (get a :ravel)) apl-io)) :scalar? true}) (else {:idxs (map (fn (x) (- x apl-io)) (get a :ravel)) :scalar? false})))) (range 0 rank)))) + (let + ((cells (apl-cartesian (map (fn (a) (get a :idxs)) axis-info)))) + (let + ((result-ravel (map (fn (cell) (let ((flat (reduce + 0 (map (fn (i) (* (nth cell i) (nth strides i))) (range 0 rank))))) (nth ravel flat))) cells))) + (let + ((result-shape (filter (fn (x) (>= x 0)) (map (fn (i) (let ((a (nth axis-info i))) (if (get a :scalar?) -1 (len (get a :idxs))))) (range 0 rank))))) + (make-array result-shape result-ravel))))))))) + +(define + apl-reduce + (fn + (f arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (if + (= (len shape) 0) + arr + (if + (= (len shape) 1) + (let + ((n (first shape))) + (if + (= n 0) + (apl-scalar 0) + (apl-scalar + (reduce + (fn (a b) (disclose (f (apl-scalar a) (apl-scalar b)))) + (first ravel) + (rest ravel))))) + (let + ((last-dim (last shape)) + (pre-shape (take shape (- (len shape) 1))) + (pre-size (reduce * 1 (take shape (- (len shape) 1))))) + (make-array + pre-shape + (map + (fn + (i) + (let + ((start (* i last-dim)) + (elems + (map + (fn (j) (nth ravel (+ start j))) + (range 0 last-dim)))) + (if + (= last-dim 0) + 0 + (reduce + (fn + (a b) + (disclose (f (apl-scalar a) (apl-scalar b)))) + (first elems) + (rest elems))))) + (range 0 pre-size))))))))) + +(define + apl-reduce-first + (fn + (f arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (if + (< (len shape) 2) + (apl-reduce f arr) + (let + ((first-dim (first shape)) + (inner-shape (rest shape)) + (inner-size (reduce * 1 (rest shape)))) + (if + (= first-dim 0) + (make-array inner-shape (map (fn (i) 0) (range 0 inner-size))) + (make-array + inner-shape + (map + (fn + (j) + (let + ((col (map (fn (i) (nth ravel (+ j (* i inner-size)))) (range 0 first-dim)))) + (reduce + (fn + (a b) + (disclose (f (apl-scalar a) (apl-scalar b)))) + (first col) + (rest col)))) + (range 0 inner-size))))))))) + +(define + apl-scan + (fn + (f arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (if + (= (len shape) 0) + arr + (if + (= (len shape) 1) + (let + ((n (first shape))) + (make-array + shape + (map + (fn + (i) + (let + ((slice (take ravel (+ i 1)))) + (reduce + (fn + (a b) + (disclose (f (apl-scalar a) (apl-scalar b)))) + (first slice) + (rest slice)))) + (range 0 n)))) + (let + ((last-dim (last shape)) + (pre-size (reduce * 1 (take shape (- (len shape) 1))))) + (make-array + shape + (flatten + (map + (fn + (i) + (let + ((start (* i last-dim)) + (row + (map + (fn (j) (nth ravel (+ start j))) + (range 0 last-dim)))) + (map + (fn + (k) + (let + ((slice (take row (+ k 1)))) + (reduce + (fn + (a b) + (disclose (f (apl-scalar a) (apl-scalar b)))) + (first slice) + (rest slice)))) + (range 0 last-dim)))) + (range 0 pre-size)))))))))) + +(define + apl-scan-first + (fn + (f arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (if + (< (len shape) 2) + (apl-scan f arr) + (let + ((first-dim (first shape)) + (inner-size (reduce * 1 (rest shape)))) + (make-array + shape + (flatten + (map + (fn + (i) + (map + (fn + (j) + (let + ((col (map (fn (k) (nth ravel (+ j (* k inner-size)))) (range 0 (+ i 1))))) + (reduce + (fn + (a b) + (disclose (f (apl-scalar a) (apl-scalar b)))) + (first col) + (rest col)))) + (range 0 inner-size))) + (range 0 first-dim))))))))) + +(define + apl-each + (fn + (f arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (make-array + shape + (map (fn (x) (disclose (f (apl-scalar x)))) ravel))))) + +(define + apl-each-dyadic + (fn + (f a b) + (cond + ((and (scalar? a) (scalar? b)) (apl-scalar (disclose (f a b)))) + ((scalar? a) + (make-array + (get b :shape) + (map (fn (x) (disclose (f a (apl-scalar x)))) (get b :ravel)))) + ((scalar? b) + (make-array + (get a :shape) + (map (fn (x) (disclose (f (apl-scalar x) b))) (get a :ravel)))) + (else + (if + (equal? (get a :shape) (get b :shape)) + (make-array + (get a :shape) + (map + (fn (x y) (disclose (f (apl-scalar x) (apl-scalar y)))) + (get a :ravel) + (get b :ravel))) + (error "length error: shape mismatch")))))) + +(define + apl-outer + (fn + (f a b) + (let + ((a-shape (get a :shape)) + (b-shape (get b :shape)) + (a-ravel (get a :ravel)) + (b-ravel (get b :ravel))) + (make-array + (append a-shape b-shape) + (flatten + (map + (fn + (x) + (map + (fn (y) (disclose (f (apl-scalar x) (apl-scalar y)))) + b-ravel)) + a-ravel)))))) + +(define + apl-inner + (fn + (f g a b) + (let + ((a-shape (get a :shape)) + (b-shape (get b :shape)) + (a-ravel (get a :ravel)) + (b-ravel (get b :ravel))) + (let + ((a-rank (len a-shape)) (b-rank (len b-shape))) + (if + (and (= a-rank 0) (= b-rank 0)) + (apl-scalar (disclose (g a b))) + (let + ((inner-dim (last a-shape)) + (a-pre (take a-shape (- a-rank 1))) + (b-post (rest b-shape))) + (let + ((a-pre-size (reduce * 1 a-pre)) + (b-post-size (reduce * 1 b-post)) + (new-shape (append a-pre b-post))) + (make-array + new-shape + (flatten + (map + (fn + (i) + (map + (fn + (j) + (let + ((pairs (map (fn (k) (disclose (g (apl-scalar (nth a-ravel (+ (* i inner-dim) k))) (apl-scalar (nth b-ravel (+ (* k b-post-size) j)))))) (range 0 inner-dim)))) + (reduce + (fn + (x y) + (disclose (f (apl-scalar x) (apl-scalar y)))) + (first pairs) + (rest pairs)))) + (range 0 b-post-size))) + (range 0 a-pre-size))))))))))) + +(define apl-commute (fn (f x) (f x x))) + +(define apl-commute-dyadic (fn (f x y) (f y x))) + +(define apl-compose (fn (f g x) (f (g x)))) + +(define apl-compose-dyadic (fn (f g x y) (f x (g y)))) + +(define + apl-power + (fn (f n x) (reduce (fn (acc i) (f acc)) x (range 0 n)))) + +(define + apl-power-fixed + (fn + (f x) + (let + ((next (f x))) + (if + (and + (equal? (get next :shape) (get x :shape)) + (equal? (get next :ravel) (get x :ravel))) + x + (apl-power-fixed f next))))) + +(define + apl-rank + (fn + (f k arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (let + ((rank (len shape))) + (if + (>= k rank) + (f arr) + (let + ((frame-shape (take shape (- rank k))) + (cell-shape (drop shape (- rank k)))) + (let + ((frame-size (reduce * 1 frame-shape)) + (cell-size (reduce * 1 cell-shape))) + (let + ((cells (map (fn (i) (let ((start (* i cell-size))) (make-array cell-shape (map (fn (j) (nth ravel (+ start j))) (range 0 cell-size))))) (range 0 frame-size)))) + (let + ((results (map (fn (c) (f c)) cells))) + (make-array + (append frame-shape (get (first results) :shape)) + (flatten (map (fn (r) (get r :ravel)) results)))))))))))) + +(define + apl-at-replace + (fn + (vals idxs arr) + (let + ((vals-ravel (get vals :ravel)) + (idxs-ravel (get idxs :ravel)) + (arr-ravel (get arr :ravel)) + (arr-shape (get arr :shape)) + (vals-scalar? (= (len (get vals :shape)) 0))) + (make-array + arr-shape + (map + (fn + (i) + (let + ((pos (index-of idxs-ravel (+ i apl-io)))) + (if + pos + (if vals-scalar? (first vals-ravel) (nth vals-ravel pos)) + (nth arr-ravel i)))) + (range 0 (len arr-ravel))))))) + +(define + apl-at-apply + (fn + (f idxs arr) + (let + ((idxs-ravel (get idxs :ravel)) + (arr-ravel (get arr :ravel)) + (arr-shape (get arr :shape))) + (make-array + arr-shape + (map + (fn + (i) + (let + ((pos (index-of idxs-ravel (+ i apl-io)))) + (if + pos + (disclose (f (apl-scalar (nth arr-ravel i)))) + (nth arr-ravel i)))) + (range 0 (len arr-ravel))))))) diff --git a/lib/apl/scoreboard.json b/lib/apl/scoreboard.json new file mode 100644 index 00000000..74c585d1 --- /dev/null +++ b/lib/apl/scoreboard.json @@ -0,0 +1,17 @@ +{ + "suites": { + "structural": {"pass": 94, "fail": 0}, + "operators": {"pass": 117, "fail": 0}, + "dfn": {"pass": 24, "fail": 0}, + "tradfn": {"pass": 25, "fail": 0}, + "valence": {"pass": 14, "fail": 0}, + "programs": {"pass": 45, "fail": 0}, + "system": {"pass": 13, "fail": 0}, + "idioms": {"pass": 64, "fail": 0}, + "eval-ops": {"pass": 14, "fail": 0}, + "pipeline": {"pass": 40, "fail": 0} + }, + "total_pass": 450, + "total_fail": 0, + "total": 450 +} diff --git a/lib/apl/scoreboard.md b/lib/apl/scoreboard.md new file mode 100644 index 00000000..31af7af5 --- /dev/null +++ b/lib/apl/scoreboard.md @@ -0,0 +1,22 @@ +# APL Conformance Scoreboard + +_Generated by `lib/apl/conformance.sh`_ + +| Suite | Pass | Fail | Total | +|-------|-----:|-----:|------:| +| structural | 94 | 0 | 94 | +| operators | 117 | 0 | 117 | +| dfn | 24 | 0 | 24 | +| tradfn | 25 | 0 | 25 | +| valence | 14 | 0 | 14 | +| programs | 45 | 0 | 45 | +| system | 13 | 0 | 13 | +| idioms | 64 | 0 | 64 | +| eval-ops | 14 | 0 | 14 | +| pipeline | 40 | 0 | 40 | +| **Total** | **450** | **0** | **450** | + +## Notes + +- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`. +- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard. diff --git a/lib/apl/test.sh b/lib/apl/test.sh new file mode 100755 index 00000000..4b0e6161 --- /dev/null +++ b/lib/apl/test.sh @@ -0,0 +1,70 @@ +#!/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:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="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/r7rs.sx") +(load "lib/apl/runtime.sx") +(load "lib/apl/tokenizer.sx") +(load "lib/apl/parser.sx") +(load "lib/apl/transpile.sx") +(epoch 2) +(eval "(define apl-test-pass 0)") +(eval "(define apl-test-fail 0)") +(eval "(define apl-test-fails (list))") +(eval "(define apl-test (fn (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 {:name name :got got :expected expected})))))))") +(epoch 3) +(load "lib/apl/tests/structural.sx") +(load "lib/apl/tests/operators.sx") +(load "lib/apl/tests/dfn.sx") +(load "lib/apl/tests/tradfn.sx") +(load "lib/apl/tests/valence.sx") +(load "lib/apl/tests/programs.sx") +(load "lib/apl/tests/system.sx") +(load "lib/apl/tests/idioms.sx") +(load "lib/apl/tests/eval-ops.sx") +(load "lib/apl/tests/pipeline.sx") +(load "lib/apl/tests/programs-e2e.sx") +(epoch 4) +(eval "(list apl-test-pass apl-test-fail)") +EPOCHS + +OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) + +LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}') +if [ -z "$LINE" ]; then + LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \ + | sed -E 's/^\(ok 4 //; 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/dfn.sx b/lib/apl/tests/dfn.sx new file mode 100644 index 00000000..0f22ad51 --- /dev/null +++ b/lib/apl/tests/dfn.sx @@ -0,0 +1,227 @@ +; Tests for apl-eval-ast and apl-call-dfn (manual AST construction). + +(define rv (fn (arr) (get arr :ravel))) +(define sh (fn (arr) (get arr :shape))) + +(define mknum (fn (n) (list :num n))) +(define mkname (fn (s) (list :name s))) +(define mkfg (fn (g) (list :fn-glyph g))) +(define mkmon (fn (g a) (list :monad (mkfg g) a))) +(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r))) +(define mkdfn1 (fn (body) (list :dfn body))) +(define mkprog (fn (stmts) (cons :program stmts))) + +(define mkasg (fn (mkname expr) (list :assign mkname expr))) + +(define mkgrd (fn (c e) (list :guard c e))) + +(define mkdfn (fn (stmts) (cons :dfn stmts))) + +(apl-test + "eval :num literal" + (rv (apl-eval-ast (mknum 42) {})) + (list 42)) + +(apl-test + "eval :num literal shape" + (sh (apl-eval-ast (mknum 42) {})) + (list)) + +(apl-test + "eval :dyad +" + (rv (apl-eval-ast (mkdyd "+" (mknum 2) (mknum 3)) {})) + (list 5)) + +(apl-test + "eval :dyad ×" + (rv (apl-eval-ast (mkdyd "×" (mknum 6) (mknum 7)) {})) + (list 42)) + +(apl-test + "eval :monad - (negate)" + (rv (apl-eval-ast (mkmon "-" (mknum 7)) {})) + (list -7)) + +(apl-test + "eval :monad ⌊ (floor)" + (rv (apl-eval-ast (mkmon "⌊" (mknum 3)) {})) + (list 3)) + +(apl-test + "eval :name ⍵ from env" + (rv (apl-eval-ast (mkname "⍵") {:omega (apl-scalar 99) :alpha nil})) + (list 99)) + +(apl-test + "eval :name ⍺ from env" + (rv (apl-eval-ast (mkname "⍺") {:omega nil :alpha (apl-scalar 7)})) + (list 7)) + +(apl-test + "dfn {⍵+1} called monadic" + (rv + (apl-call-dfn-m + (mkdfn1 (mkdyd "+" (mkname "⍵") (mknum 1))) + (apl-scalar 5))) + (list 6)) + +(apl-test + "dfn {⍺+⍵} called dyadic" + (rv + (apl-call-dfn + (mkdfn1 (mkdyd "+" (mkname "⍺") (mkname "⍵"))) + (apl-scalar 4) + (apl-scalar 9))) + (list 13)) + +(apl-test + "dfn {⍺×⍵} dyadic on vectors" + (rv + (apl-call-dfn + (mkdfn1 (mkdyd "×" (mkname "⍺") (mkname "⍵"))) + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 10 20 30)))) + (list 10 40 90)) + +(apl-test + "dfn {-⍵} monadic negate" + (rv + (apl-call-dfn-m + (mkdfn1 (mkmon "-" (mkname "⍵"))) + (make-array (list 3) (list 1 2 3)))) + (list -1 -2 -3)) + +(apl-test + "dfn {⍺-⍵} dyadic subtract scalar" + (rv + (apl-call-dfn + (mkdfn1 (mkdyd "-" (mkname "⍺") (mkname "⍵"))) + (apl-scalar 10) + (apl-scalar 3))) + (list 7)) + +(apl-test + "dfn {⌈⍺,⍵} not used (just verify : missing) — ceiling of right" + (rv + (apl-call-dfn-m (mkdfn1 (mkmon "⌈" (mkname "⍵"))) (apl-scalar 5))) + (list 5)) + +(apl-test + "dfn nested dyad" + (rv + (apl-call-dfn + (mkdfn1 + (mkdyd "+" (mkname "⍺") (mkdyd "×" (mkname "⍵") (mknum 2)))) + (apl-scalar 1) + (apl-scalar 3))) + (list 7)) + +(apl-test + "dfn local assign x←⍵+1; ⍺×x" + (rv + (apl-call-dfn + (mkdfn + (list + (mkasg "x" (mkdyd "+" (mkname "⍵") (mknum 1))) + (mkdyd "×" (mkname "⍺") (mkname "x")))) + (apl-scalar 3) + (apl-scalar 4))) + (list 15)) + +(apl-test + "dfn guard: 0=⍵:99; ⍵×2 (true branch)" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 99)) + (mkdyd "×" (mkname "⍵") (mknum 2)))) + (apl-scalar 0))) + (list 99)) + +(apl-test + "dfn guard: 0=⍵:99; ⍵×2 (false branch)" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 99)) + (mkdyd "×" (mkname "⍵") (mknum 2)))) + (apl-scalar 5))) + (list 10)) + +(apl-test + "dfn default ⍺←10 used (monadic call)" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkasg "⍺" (mknum 10)) + (mkdyd "+" (mkname "⍺") (mkname "⍵")))) + (apl-scalar 5))) + (list 15)) + +(apl-test + "dfn default ⍺←10 ignored when ⍺ given (dyadic call)" + (rv + (apl-call-dfn + (mkdfn + (list + (mkasg "⍺" (mknum 10)) + (mkdyd "+" (mkname "⍺") (mkname "⍵")))) + (apl-scalar 100) + (apl-scalar 5))) + (list 105)) + +(apl-test + "dfn ∇ recursion: factorial via guard" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 1)) + (mkdyd + "×" + (mkname "⍵") + (mkmon "∇" (mkdyd "-" (mkname "⍵") (mknum 1)))))) + (apl-scalar 5))) + (list 120)) + +(apl-test + "dfn ∇ recursion: 3 → 6 (factorial)" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 1)) + (mkdyd + "×" + (mkname "⍵") + (mkmon "∇" (mkdyd "-" (mkname "⍵") (mknum 1)))))) + (apl-scalar 3))) + (list 6)) + +(apl-test + "dfn local: x←⍵+10; y←x×2; y" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkasg "x" (mkdyd "+" (mkname "⍵") (mknum 10))) + (mkasg "y" (mkdyd "×" (mkname "x") (mknum 2))) + (mkname "y"))) + (apl-scalar 5))) + (list 30)) + +(apl-test + "dfn first guard wins: many guards" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkgrd (mkdyd "=" (mknum 1) (mkname "⍵")) (mknum 100)) + (mkgrd (mkdyd "=" (mknum 2) (mkname "⍵")) (mknum 200)) + (mkgrd (mkdyd "=" (mknum 3) (mkname "⍵")) (mknum 300)) + (mknum 0))) + (apl-scalar 2))) + (list 200)) diff --git a/lib/apl/tests/eval-ops.sx b/lib/apl/tests/eval-ops.sx new file mode 100644 index 00000000..36e20241 --- /dev/null +++ b/lib/apl/tests/eval-ops.sx @@ -0,0 +1,147 @@ +; Tests for operator handling in apl-eval-ast (Phase 7). +; Manual AST construction; verifies :derived-fn / :outer / :derived-fn2 +; route through apl-resolve-monadic / apl-resolve-dyadic correctly. + +(define mkrv (fn (arr) (get arr :ravel))) +(define mksh (fn (arr) (get arr :shape))) +(define mknum (fn (n) (list :num n))) +(define mkfg (fn (g) (list :fn-glyph g))) +(define mkmon (fn (g a) (list :monad g a))) +(define mkdyd (fn (g l r) (list :dyad g l r))) +(define mkder (fn (op f) (list :derived-fn op f))) +(define mkdr2 (fn (op f g) (list :derived-fn2 op f g))) +(define mkout (fn (f) (list :outer "∘." f))) + +; helper: literal vector AST via :vec (from list of values) +(define mkvec (fn (xs) (cons :vec (map (fn (n) (mknum n)) xs)))) + +; ---------- monadic operators ---------- + +(apl-test + "eval-ast +/ ⍳5 → 15" + (mkrv + (apl-eval-ast + (mkmon (mkder "/" (mkfg "+")) (mkmon (mkfg "⍳") (mknum 5))) + {})) + (list 15)) + +(apl-test + "eval-ast ×/ ⍳5 → 120" + (mkrv + (apl-eval-ast + (mkmon (mkder "/" (mkfg "×")) (mkmon (mkfg "⍳") (mknum 5))) + {})) + (list 120)) + +(apl-test + "eval-ast ⌈/ — max reduce" + (mkrv + (apl-eval-ast + (mkmon (mkder "/" (mkfg "⌈")) (mkvec (list 3 1 4 1 5 9 2 6))) + {})) + (list 9)) + +(apl-test + "eval-ast +\\ scan" + (mkrv + (apl-eval-ast + (mkmon (mkder "\\" (mkfg "+")) (mkvec (list 1 2 3 4 5))) + {})) + (list 1 3 6 10 15)) + +(apl-test + "eval-ast +⌿ first-axis reduce on vector" + (mkrv + (apl-eval-ast + (mkmon (mkder "⌿" (mkfg "+")) (mkvec (list 1 2 3 4 5))) + {})) + (list 15)) + +(apl-test + "eval-ast -¨ each-negate" + (mkrv + (apl-eval-ast + (mkmon (mkder "¨" (mkfg "-")) (mkvec (list 1 2 3 4))) + {})) + (list -1 -2 -3 -4)) + +(apl-test + "eval-ast +⍨ commute (double via x+x)" + (mkrv + (apl-eval-ast (mkmon (mkder "⍨" (mkfg "+")) (mknum 7)) {})) + (list 14)) + +; ---------- dyadic operators ---------- + +(apl-test + "eval-ast outer ∘.× — multiplication table" + (mkrv + (apl-eval-ast + (mkdyd + (mkout (mkfg "×")) + (mkvec (list 1 2 3)) + (mkvec (list 1 2 3))) + {})) + (list 1 2 3 2 4 6 3 6 9)) + +(apl-test + "eval-ast outer ∘.× shape (3 3)" + (mksh + (apl-eval-ast + (mkdyd + (mkout (mkfg "×")) + (mkvec (list 1 2 3)) + (mkvec (list 1 2 3))) + {})) + (list 3 3)) + +(apl-test + "eval-ast inner +.× — dot product" + (mkrv + (apl-eval-ast + (mkdyd + (mkdr2 "." (mkfg "+") (mkfg "×")) + (mkvec (list 1 2 3)) + (mkvec (list 4 5 6))) + {})) + (list 32)) + +(apl-test + "eval-ast inner ∧.= equal vectors" + (mkrv + (apl-eval-ast + (mkdyd + (mkdr2 "." (mkfg "∧") (mkfg "=")) + (mkvec (list 1 2 3)) + (mkvec (list 1 2 3))) + {})) + (list 1)) + +(apl-test + "eval-ast each-dyadic +¨" + (mkrv + (apl-eval-ast + (mkdyd + (mkder "¨" (mkfg "+")) + (mkvec (list 1 2 3)) + (mkvec (list 10 20 30))) + {})) + (list 11 22 33)) + +(apl-test + "eval-ast commute -⍨ (subtract swapped)" + (mkrv + (apl-eval-ast + (mkdyd (mkder "⍨" (mkfg "-")) (mknum 5) (mknum 3)) + {})) + (list -2)) + +; ---------- nested operators ---------- + +(apl-test + "eval-ast +/¨ — sum of each" + (mkrv + (apl-eval-ast + (mkmon (mkder "/" (mkfg "+")) (mkvec (list 10 20 30))) + {})) + (list 60)) diff --git a/lib/apl/tests/idioms.sx b/lib/apl/tests/idioms.sx new file mode 100644 index 00000000..40475a3d --- /dev/null +++ b/lib/apl/tests/idioms.sx @@ -0,0 +1,359 @@ +; APL idiom corpus — classic Roger Hui / Phil Last idioms expressed +; through our runtime primitives. Each test names the APL one-liner +; and verifies the equivalent runtime call. + +(define mkrv (fn (arr) (get arr :ravel))) +(define mksh (fn (arr) (get arr :shape))) + +; ---------- reductions ---------- + +(apl-test + "+/⍵ — sum" + (mkrv (apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5)))) + (list 15)) + +(apl-test + "(+/⍵)÷⍴⍵ — mean" + (mkrv + (apl-div + (apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5))) + (apl-scalar 5))) + (list 3)) + +(apl-test + "⌈/⍵ — max" + (mkrv (apl-reduce apl-max (make-array (list 6) (list 3 1 4 1 5 9)))) + (list 9)) + +(apl-test + "⌊/⍵ — min" + (mkrv (apl-reduce apl-min (make-array (list 6) (list 3 1 4 1 5 9)))) + (list 1)) + +(apl-test + "(⌈/⍵)-⌊/⍵ — range" + (mkrv + (apl-sub + (apl-reduce apl-max (make-array (list 6) (list 3 1 4 1 5 9))) + (apl-reduce apl-min (make-array (list 6) (list 3 1 4 1 5 9))))) + (list 8)) + +(apl-test + "×/⍵ — product" + (mkrv (apl-reduce apl-mul (make-array (list 4) (list 1 2 3 4)))) + (list 24)) + +(apl-test + "+\\⍵ — running sum" + (mkrv (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 3 6 10 15)) + +; ---------- sort / order ---------- + +(apl-test + "⍵[⍋⍵] — sort ascending" + (mkrv (apl-quicksort (make-array (list 5) (list 3 1 4 1 5)))) + (list 1 1 3 4 5)) + +(apl-test + "⌽⍵ — reverse" + (mkrv (apl-reverse (make-array (list 5) (list 1 2 3 4 5)))) + (list 5 4 3 2 1)) + +(apl-test + "⊃⌽⍵ — last element" + (mkrv + (apl-disclose (apl-reverse (make-array (list 4) (list 10 20 30 40))))) + (list 40)) + +(apl-test + "1↑⍵ — first element" + (mkrv + (apl-take (apl-scalar 1) (make-array (list 4) (list 10 20 30 40)))) + (list 10)) + +(apl-test + "1↓⍵ — drop first" + (mkrv + (apl-drop (apl-scalar 1) (make-array (list 4) (list 10 20 30 40)))) + (list 20 30 40)) + +(apl-test + "¯1↓⍵ — drop last" + (mkrv + (apl-drop (apl-scalar -1) (make-array (list 4) (list 10 20 30 40)))) + (list 10 20 30)) + +; ---------- counts / membership ---------- + +(apl-test + "≢⍵ — tally" + (mkrv (apl-tally (make-array (list 7) (list 9 8 7 6 5 4 3)))) + (list 7)) + +(apl-test + "+/⍵=v — count occurrences of v" + (mkrv + (apl-reduce + apl-add + (apl-eq (make-array (list 7) (list 1 2 3 2 1 3 2)) (apl-scalar 2)))) + (list 3)) + +(apl-test + "0=N|M — divisibility test" + (mkrv (apl-eq (apl-scalar 0) (apl-mod (apl-scalar 3) (apl-scalar 12)))) + (list 1)) + +; ---------- shape constructors ---------- + +(apl-test + "N⍴1 — vector of N ones" + (mkrv (apl-reshape (apl-scalar 5) (apl-scalar 1))) + (list 1 1 1 1 1)) + +(apl-test + "(N N)⍴0 — N×N zero matrix" + (mkrv (apl-reshape (make-array (list 2) (list 3 3)) (apl-scalar 0))) + (list 0 0 0 0 0 0 0 0 0)) + +(apl-test + "⍳∘.=⍳ — N×N identity matrix" + (mkrv + (apl-outer apl-eq (apl-iota (apl-scalar 3)) (apl-iota (apl-scalar 3)))) + (list 1 0 0 0 1 0 0 0 1)) + +(apl-test + "⍳∘.×⍳ — multiplication table" + (mkrv + (apl-outer apl-mul (apl-iota (apl-scalar 3)) (apl-iota (apl-scalar 3)))) + (list 1 2 3 2 4 6 3 6 9)) + +; ---------- numerical idioms ---------- + +(apl-test + "+\\⍳N — triangular numbers" + (mkrv (apl-scan apl-add (apl-iota (apl-scalar 5)))) + (list 1 3 6 10 15)) + +(apl-test + "+/⍳N=N×(N+1)÷2 — sum of 1..N" + (mkrv (apl-reduce apl-add (apl-iota (apl-scalar 10)))) + (list 55)) + +(apl-test + "×/⍳N — factorial via iota" + (mkrv (apl-reduce apl-mul (apl-iota (apl-scalar 5)))) + (list 120)) + +(apl-test + "2|⍵ — parity (1=odd)" + (mkrv (apl-mod (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 0 1 0 1)) + +(apl-test + "+/2|⍵ — count odd" + (mkrv + (apl-reduce + apl-add + (apl-mod (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5))))) + (list 3)) + +; ---------- boolean idioms ---------- + +(apl-test + "∧/⍵ — all-true" + (mkrv (apl-reduce apl-and (make-array (list 4) (list 1 1 1 1)))) + (list 1)) + +(apl-test + "∧/⍵ — all-true with zero is false" + (mkrv (apl-reduce apl-and (make-array (list 4) (list 1 1 0 1)))) + (list 0)) + +(apl-test + "∨/⍵ — any-true" + (mkrv (apl-reduce apl-or (make-array (list 4) (list 0 0 1 0)))) + (list 1)) + +(apl-test + "∨/⍵ — any-true all zero is false" + (mkrv (apl-reduce apl-or (make-array (list 4) (list 0 0 0 0)))) + (list 0)) + +; ---------- selection / scaling ---------- + +(apl-test + "⍵×⍵ — square each" + (mkrv + (apl-mul + (make-array (list 4) (list 1 2 3 4)) + (make-array (list 4) (list 1 2 3 4)))) + (list 1 4 9 16)) + +(apl-test + "+/⍵×⍵ — sum of squares" + (mkrv + (apl-reduce + apl-add + (apl-mul + (make-array (list 4) (list 1 2 3 4)) + (make-array (list 4) (list 1 2 3 4))))) + (list 30)) + +(apl-test + "⍵-(+/⍵)÷⍴⍵ — mean-centered" + (mkrv + (apl-sub + (make-array (list 5) (list 2 4 6 8 10)) + (apl-div + (apl-reduce apl-add (make-array (list 5) (list 2 4 6 8 10))) + (apl-scalar 5)))) + (list -4 -2 0 2 4)) + +; ---------- shape / structure ---------- + +(apl-test + ",⍵ — ravel" + (mkrv (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 2 3 4 5 6)) + +(apl-test + "⍴⍴⍵ — rank" + (mkrv + (apl-shape (apl-shape (make-array (list 2 3) (list 1 2 3 4 5 6))))) + (list 2)) + +(apl-test + "src: +/⍳N → triangular(N)" + (mkrv (apl-run "+/⍳100")) + (list 5050)) + +(apl-test "src: ×/⍳N → N!" (mkrv (apl-run "×/⍳6")) (list 720)) + +(apl-test + "src: ⌈/V — max" + (mkrv (apl-run "⌈/3 1 4 1 5 9 2 6")) + (list 9)) + +(apl-test + "src: ⌊/V — min" + (mkrv (apl-run "⌊/3 1 4 1 5 9 2 6")) + (list 1)) + +(apl-test + "src: range = (⌈/V) - ⌊/V" + (mkrv (apl-run "(⌈/3 1 4 1 5 9 2 6) - ⌊/3 1 4 1 5 9 2 6")) + (list 8)) + +(apl-test + "src: +\\V — running sum" + (mkrv (apl-run "+\\1 2 3 4 5")) + (list 1 3 6 10 15)) + +(apl-test + "src: ×\\V — running product" + (mkrv (apl-run "×\\1 2 3 4 5")) + (list 1 2 6 24 120)) + +(apl-test + "src: V × V — squares" + (mkrv (apl-run "(⍳5) × ⍳5")) + (list 1 4 9 16 25)) + +(apl-test + "src: +/V × V — sum of squares" + (mkrv (apl-run "+/(⍳5) × ⍳5")) + (list 55)) + +(apl-test "src: ∧/V — all-true" (mkrv (apl-run "∧/1 1 1 1")) (list 1)) + +(apl-test "src: ∨/V — any-true" (mkrv (apl-run "∨/0 0 1 0")) (list 1)) + +(apl-test "src: 0 = N|M — divides" (mkrv (apl-run "0 = 3 | 12")) (list 1)) + +(apl-test + "src: 2 | V — parity" + (mkrv (apl-run "2 | 1 2 3 4 5 6")) + (list 1 0 1 0 1 0)) + +(apl-test + "src: +/2|V — count odd" + (mkrv (apl-run "+/2 | 1 2 3 4 5 6")) + (list 3)) + +(apl-test "src: ⍴ V" (mkrv (apl-run "⍴ 1 2 3 4 5")) (list 5)) + +(apl-test + "src: ⍴⍴ M — rank" + (mkrv (apl-run "⍴ ⍴ (2 3) ⍴ ⍳6")) + (list 2)) + +(apl-test + "src: N⍴1 — vector of ones" + (mkrv (apl-run "5 ⍴ 1")) + (list 1 1 1 1 1)) + +(apl-test + "src: ⍳N ∘.= ⍳N — identity matrix" + (mkrv (apl-run "(⍳3) ∘.= ⍳3")) + (list 1 0 0 0 1 0 0 0 1)) + +(apl-test + "src: ⍳N ∘.× ⍳N — multiplication table" + (mkrv (apl-run "(⍳3) ∘.× ⍳3")) + (list 1 2 3 2 4 6 3 6 9)) + +(apl-test + "src: V +.× V — dot product" + (mkrv (apl-run "1 2 3 +.× 4 5 6")) + (list 32)) + +(apl-test + "src: ∧.= V — vectors equal?" + (mkrv (apl-run "1 2 3 ∧.= 1 2 3")) + (list 1)) + +(apl-test + "src: V[1] — first element" + (mkrv (apl-run "(10 20 30 40)[1]")) + (list 10)) + +(apl-test + "src: 1↑V — first via take" + (mkrv (apl-run "1 ↑ 10 20 30 40")) + (list 10)) + +(apl-test + "src: 1↓V — drop first" + (mkrv (apl-run "1 ↓ 10 20 30 40")) + (list 20 30 40)) + +(apl-test + "src: ¯1↓V — drop last" + (mkrv (apl-run "¯1 ↓ 10 20 30 40")) + (list 10 20 30)) + +(apl-test + "src: ⌽V — reverse" + (mkrv (apl-run "⌽ 1 2 3 4 5")) + (list 5 4 3 2 1)) + +(apl-test + "src: ≢V — tally" + (mkrv (apl-run "≢ 9 8 7 6 5 4 3 2 1")) + (list 9)) + +(apl-test + "src: ,M — ravel" + (mkrv (apl-run ", (2 3) ⍴ ⍳6")) + (list 1 2 3 4 5 6)) + +(apl-test + "src: A=V — count occurrences" + (mkrv (apl-run "+/2 = 1 2 3 2 1 3 2")) + (list 3)) + +(apl-test + "src: ⌈/(V × V) — max squared" + (mkrv (apl-run "⌈/(1 2 3 4 5) × 1 2 3 4 5")) + (list 25)) diff --git a/lib/apl/tests/operators.sx b/lib/apl/tests/operators.sx new file mode 100644 index 00000000..afd21895 --- /dev/null +++ b/lib/apl/tests/operators.sx @@ -0,0 +1,791 @@ +(define rv (fn (arr) (get arr :ravel))) +(define sh (fn (arr) (get arr :shape))) + +(apl-test + "reduce +/ vector" + (rv (apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5)))) + (list 15)) + +(apl-test + "reduce x/ vector" + (rv (apl-reduce apl-mul (make-array (list 4) (list 1 2 3 4)))) + (list 24)) + +(apl-test + "reduce max/ vector" + (rv (apl-reduce apl-max (make-array (list 5) (list 3 1 4 1 5)))) + (list 5)) + +(apl-test + "reduce min/ vector" + (rv (apl-reduce apl-min (make-array (list 3) (list 3 1 4)))) + (list 1)) + +(apl-test + "reduce and/ all true" + (rv (apl-reduce apl-and (make-array (list 3) (list 1 1 1)))) + (list 1)) + +(apl-test + "reduce or/ with true" + (rv (apl-reduce apl-or (make-array (list 3) (list 0 0 1)))) + (list 1)) + +(apl-test + "reduce +/ single element" + (rv (apl-reduce apl-add (make-array (list 1) (list 42)))) + (list 42)) + +(apl-test + "reduce +/ scalar no-op" + (rv (apl-reduce apl-add (apl-scalar 7))) + (list 7)) + +(apl-test + "reduce +/ shape is scalar" + (sh (apl-reduce apl-add (make-array (list 4) (list 1 2 3 4)))) + (list)) + +(apl-test + "reduce +/ matrix row sums shape" + (sh (apl-reduce apl-add (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 2)) + +(apl-test + "reduce +/ matrix row sums values" + (rv (apl-reduce apl-add (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 6 15)) + +(apl-test + "reduce max/ matrix row maxima" + (rv (apl-reduce apl-max (make-array (list 2 3) (list 3 1 4 1 5 9)))) + (list 4 9)) + +(apl-test + "reduce-first +/ vector same as reduce" + (rv (apl-reduce-first apl-add (make-array (list 5) (list 1 2 3 4 5)))) + (list 15)) + +(apl-test + "reduce-first +/ matrix col sums shape" + (sh + (apl-reduce-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 3)) + +(apl-test + "reduce-first +/ matrix col sums values" + (rv + (apl-reduce-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 5 7 9)) + +(apl-test + "reduce-first max/ matrix col maxima" + (rv + (apl-reduce-first apl-max (make-array (list 3 2) (list 1 9 2 8 3 7)))) + (list 3 9)) + +(apl-test + "scan +\\ vector" + (rv (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 3 6 10 15)) + +(apl-test + "scan x\\ vector cumulative product" + (rv (apl-scan apl-mul (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 2 6 24 120)) + +(apl-test + "scan max\\ vector running max" + (rv (apl-scan apl-max (make-array (list 5) (list 3 1 4 1 5)))) + (list 3 3 4 4 5)) + +(apl-test + "scan min\\ vector running min" + (rv (apl-scan apl-min (make-array (list 5) (list 3 1 4 1 5)))) + (list 3 1 1 1 1)) + +(apl-test + "scan +\\ single element" + (rv (apl-scan apl-add (make-array (list 1) (list 42)))) + (list 42)) + +(apl-test + "scan +\\ scalar no-op" + (rv (apl-scan apl-add (apl-scalar 7))) + (list 7)) + +(apl-test + "scan +\\ vector preserves shape" + (sh (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5)))) + (list 5)) + +(apl-test + "scan +\\ matrix preserves shape" + (sh (apl-scan apl-add (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 2 3)) + +(apl-test + "scan +\\ matrix row-wise" + (rv (apl-scan apl-add (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 3 6 4 9 15)) + +(apl-test + "scan max\\ matrix row-wise running max" + (rv (apl-scan apl-max (make-array (list 2 3) (list 3 1 4 1 5 9)))) + (list 3 3 4 1 5 9)) + +(apl-test + "scan-first +\\ vector same as scan" + (rv (apl-scan-first apl-add (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 3 6 10 15)) + +(apl-test + "scan-first +\\ scalar no-op" + (rv (apl-scan-first apl-add (apl-scalar 9))) + (list 9)) + +(apl-test + "scan-first +\\ matrix preserves shape" + (sh (apl-scan-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 2 3)) + +(apl-test + "scan-first +\\ matrix col-wise" + (rv (apl-scan-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 2 3 5 7 9)) + +(apl-test + "scan-first max\\ matrix col-wise running max" + (rv (apl-scan-first apl-max (make-array (list 3 2) (list 3 1 4 1 5 9)))) + (list 3 1 4 1 5 9)) + +(apl-test + "each negate vector" + (rv (apl-each apl-neg-m (make-array (list 3) (list 1 2 3)))) + (list -1 -2 -3)) + +(apl-test + "each negate vector preserves shape" + (sh (apl-each apl-neg-m (make-array (list 3) (list 1 2 3)))) + (list 3)) + +(apl-test + "each reciprocal vector" + (rv (apl-each apl-recip (make-array (list 3) (list 1 2 4)))) + (list 1 (/ 1 2) (/ 1 4))) + +(apl-test + "each abs vector" + (rv (apl-each apl-abs (make-array (list 4) (list -1 2 -3 4)))) + (list 1 2 3 4)) + +(apl-test "each scalar" (rv (apl-each apl-neg-m (apl-scalar 5))) (list -5)) + +(apl-test + "each scalar shape" + (sh (apl-each apl-neg-m (apl-scalar 5))) + (list)) + +(apl-test + "each negate matrix shape" + (sh (apl-each apl-neg-m (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 2 3)) + +(apl-test + "each negate matrix values" + (rv (apl-each apl-neg-m (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list -1 -2 -3 -4 -5 -6)) + +(apl-test + "each-dyadic scalar+scalar" + (rv (apl-each-dyadic apl-add (apl-scalar 3) (apl-scalar 4))) + (list 7)) + +(apl-test + "each-dyadic scalar+vector" + (rv + (apl-each-dyadic + apl-add + (apl-scalar 10) + (make-array (list 3) (list 1 2 3)))) + (list 11 12 13)) + +(apl-test + "each-dyadic vector+scalar" + (rv + (apl-each-dyadic + apl-add + (make-array (list 3) (list 1 2 3)) + (apl-scalar 10))) + (list 11 12 13)) + +(apl-test + "each-dyadic vector+vector" + (rv + (apl-each-dyadic + apl-add + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 10 20 30)))) + (list 11 22 33)) + +(apl-test + "each-dyadic mul matrix+matrix shape" + (sh + (apl-each-dyadic + apl-mul + (make-array (list 2 2) (list 1 2 3 4)) + (make-array (list 2 2) (list 5 6 7 8)))) + (list 2 2)) + +(apl-test + "each-dyadic mul matrix+matrix values" + (rv + (apl-each-dyadic + apl-mul + (make-array (list 2 2) (list 1 2 3 4)) + (make-array (list 2 2) (list 5 6 7 8)))) + (list 5 12 21 32)) + +(apl-test + "outer product mult table values" + (rv + (apl-outer + apl-mul + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 1 2 3)))) + (list 1 2 3 2 4 6 3 6 9)) + +(apl-test + "outer product mult table shape" + (sh + (apl-outer + apl-mul + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 1 2 3)))) + (list 3 3)) + +(apl-test + "outer product add table values" + (rv + (apl-outer + apl-add + (make-array (list 2) (list 1 2)) + (make-array (list 3) (list 10 20 30)))) + (list 11 21 31 12 22 32)) + +(apl-test + "outer product add table shape" + (sh + (apl-outer + apl-add + (make-array (list 2) (list 1 2)) + (make-array (list 3) (list 10 20 30)))) + (list 2 3)) + +(apl-test + "outer product scalar+vector shape" + (sh + (apl-outer apl-mul (apl-scalar 5) (make-array (list 3) (list 1 2 3)))) + (list 3)) + +(apl-test + "outer product scalar+vector values" + (rv + (apl-outer apl-mul (apl-scalar 5) (make-array (list 3) (list 1 2 3)))) + (list 5 10 15)) + +(apl-test + "outer product vector+scalar shape" + (sh + (apl-outer apl-mul (make-array (list 3) (list 1 2 3)) (apl-scalar 10))) + (list 3)) + +(apl-test + "outer product scalar+scalar" + (rv (apl-outer apl-mul (apl-scalar 6) (apl-scalar 7))) + (list 42)) + +(apl-test + "outer product scalar+scalar shape" + (sh (apl-outer apl-mul (apl-scalar 6) (apl-scalar 7))) + (list)) + +(apl-test + "outer product equality identity matrix values" + (rv + (apl-outer + apl-eq + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 1 2 3)))) + (list 1 0 0 0 1 0 0 0 1)) + +(apl-test + "outer product matrix+vector rank doubling shape" + (sh + (apl-outer + apl-add + (make-array (list 2 2) (list 1 2 3 4)) + (make-array (list 3) (list 10 20 30)))) + (list 2 2 3)) + +(apl-test + "outer product matrix+vector rank doubling values" + (rv + (apl-outer + apl-add + (make-array (list 2 2) (list 1 2 3 4)) + (make-array (list 3) (list 10 20 30)))) + (list 11 21 31 12 22 32 13 23 33 14 24 34)) + +(apl-test + "inner +.× dot product" + (rv + (apl-inner + apl-add + apl-mul + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 4 5 6)))) + (list 32)) + +(apl-test + "inner +.× dot product shape is scalar" + (sh + (apl-inner + apl-add + apl-mul + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 4 5 6)))) + (list)) + +(apl-test + "inner +.× matrix multiply 2x3 * 3x2 shape" + (sh + (apl-inner + apl-add + apl-mul + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 3 2) (list 7 8 9 10 11 12)))) + (list 2 2)) + +(apl-test + "inner +.× matrix multiply 2x3 * 3x2 values" + (rv + (apl-inner + apl-add + apl-mul + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 3 2) (list 7 8 9 10 11 12)))) + (list 58 64 139 154)) + +(apl-test + "inner +.× identity matrix 2x2" + (rv + (apl-inner + apl-add + apl-mul + (make-array (list 2 2) (list 1 0 0 1)) + (make-array (list 2 2) (list 5 6 7 8)))) + (list 5 6 7 8)) + +(apl-test + "inner ∧.= equal vectors" + (rv + (apl-inner + apl-and + apl-eq + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 1 2 3)))) + (list 1)) + +(apl-test + "inner ∧.= unequal vectors" + (rv + (apl-inner + apl-and + apl-eq + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 1 9 3)))) + (list 0)) + +(apl-test + "inner +.× matrix * vector shape" + (sh + (apl-inner + apl-add + apl-mul + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 3) (list 7 8 9)))) + (list 2)) + +(apl-test + "inner +.× matrix * vector values" + (rv + (apl-inner + apl-add + apl-mul + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 3) (list 7 8 9)))) + (list 50 122)) + +(apl-test + "inner +.× vector * matrix shape" + (sh + (apl-inner + apl-add + apl-mul + (make-array (list 3) (list 1 2 3)) + (make-array (list 3 2) (list 4 5 6 7 8 9)))) + (list 2)) + +(apl-test + "inner +.× vector * matrix values" + (rv + (apl-inner + apl-add + apl-mul + (make-array (list 3) (list 1 2 3)) + (make-array (list 3 2) (list 4 5 6 7 8 9)))) + (list 40 46)) + +(apl-test + "inner +.× single-element vectors" + (rv + (apl-inner + apl-add + apl-mul + (make-array (list 1) (list 6)) + (make-array (list 1) (list 7)))) + (list 42)) + +(apl-test + "commute +⍨ scalar doubles" + (rv (apl-commute apl-add (apl-scalar 5))) + (list 10)) + +(apl-test + "commute ×⍨ vector squares" + (rv (apl-commute apl-mul (make-array (list 4) (list 1 2 3 4)))) + (list 1 4 9 16)) + +(apl-test + "commute +⍨ vector doubles" + (rv (apl-commute apl-add (make-array (list 3) (list 1 2 3)))) + (list 2 4 6)) + +(apl-test + "commute +⍨ shape preserved" + (sh (apl-commute apl-add (make-array (list 3) (list 1 2 3)))) + (list 3)) + +(apl-test + "commute ×⍨ matrix shape preserved" + (sh (apl-commute apl-mul (make-array (list 2 2) (list 1 2 3 4)))) + (list 2 2)) + +(apl-test + "commute-dyadic -⍨ swaps subtraction" + (rv (apl-commute-dyadic apl-sub (apl-scalar 5) (apl-scalar 3))) + (list -2)) + +(apl-test + "commute-dyadic ÷⍨ swaps division" + (rv (apl-commute-dyadic apl-div (apl-scalar 4) (apl-scalar 12))) + (list 3)) + +(apl-test + "commute-dyadic -⍨ on vectors" + (rv + (apl-commute-dyadic + apl-sub + (make-array (list 3) (list 10 20 30)) + (make-array (list 3) (list 1 2 3)))) + (list -9 -18 -27)) + +(apl-test + "commute-dyadic +⍨ commutative same result" + (rv + (apl-commute-dyadic + apl-add + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 10 20 30)))) + (list 11 22 33)) + +(apl-test + "commute-dyadic ×⍨ commutative same result" + (rv + (apl-commute-dyadic + apl-mul + (make-array (list 3) (list 2 3 4)) + (make-array (list 3) (list 5 6 7)))) + (list 10 18 28)) + +(apl-test + "compose -∘| scalar (negative abs)" + (rv (apl-compose apl-neg-m apl-abs (apl-scalar -7))) + (list -7)) + +(apl-test + "compose -∘| vector" + (rv + (apl-compose apl-neg-m apl-abs (make-array (list 4) (list -1 2 -3 4)))) + (list -1 -2 -3 -4)) + +(apl-test + "compose ⌊∘- (floor of negate)" + (rv (apl-compose apl-floor apl-neg-m (make-array (list 3) (list 1 2 3)))) + (list -1 -2 -3)) + +(apl-test + "compose -∘| matrix shape preserved" + (sh + (apl-compose apl-neg-m apl-abs (make-array (list 2 2) (list -1 2 -3 4)))) + (list 2 2)) + +(apl-test + "compose-dyadic +∘- equals subtract scalar" + (rv (apl-compose-dyadic apl-add apl-neg-m (apl-scalar 10) (apl-scalar 3))) + (list 7)) + +(apl-test + "compose-dyadic +∘- equals subtract vector" + (rv + (apl-compose-dyadic + apl-add + apl-neg-m + (make-array (list 3) (list 10 20 30)) + (make-array (list 3) (list 1 2 3)))) + (list 9 18 27)) + +(apl-test + "compose-dyadic -∘| (subtract abs)" + (rv (apl-compose-dyadic apl-sub apl-abs (apl-scalar 10) (apl-scalar -3))) + (list 7)) + +(apl-test + "compose-dyadic ×∘- (multiply by negative)" + (rv + (apl-compose-dyadic + apl-mul + apl-neg-m + (make-array (list 3) (list 2 3 4)) + (make-array (list 3) (list 1 2 3)))) + (list -2 -6 -12)) + +(apl-test + "compose-dyadic shape preserved" + (sh + (apl-compose-dyadic + apl-add + apl-neg-m + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 2 3) (list 1 1 1 1 1 1)))) + (list 2 3)) + +(apl-test + "power n=0 identity" + (rv (apl-power (fn (a) (apl-add a (apl-scalar 1))) 0 (apl-scalar 5))) + (list 5)) + +(apl-test + "power increment by 3" + (rv (apl-power (fn (a) (apl-add a (apl-scalar 1))) 3 (apl-scalar 0))) + (list 3)) + +(apl-test + "power double 4 times = 16" + (rv (apl-power (fn (a) (apl-mul a (apl-scalar 2))) 4 (apl-scalar 1))) + (list 16)) + +(apl-test + "power on vector +5" + (rv + (apl-power + (fn (a) (apl-add a (apl-scalar 1))) + 5 + (make-array (list 3) (list 1 2 3)))) + (list 6 7 8)) + +(apl-test + "power on vector preserves shape" + (sh + (apl-power + (fn (a) (apl-add a (apl-scalar 1))) + 5 + (make-array (list 3) (list 1 2 3)))) + (list 3)) + +(apl-test + "power on matrix" + (rv + (apl-power + (fn (a) (apl-mul a (apl-scalar 3))) + 2 + (make-array (list 2 2) (list 1 2 3 4)))) + (list 9 18 27 36)) + +(apl-test + "power-fixed identity stops immediately" + (rv (apl-power-fixed (fn (a) a) (make-array (list 3) (list 1 2 3)))) + (list 1 2 3)) + +(apl-test + "power-fixed floor half scalar to 0" + (rv + (apl-power-fixed + (fn (a) (apl-floor (apl-div a (apl-scalar 2)))) + (apl-scalar 100))) + (list 0)) + +(apl-test + "power-fixed shape preserved" + (sh + (apl-power-fixed (fn (a) a) (make-array (list 2 2) (list 1 2 3 4)))) + (list 2 2)) + +(apl-test + "rank tally⍤1 row tallies" + (rv (apl-rank apl-tally 1 (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 3 3)) + +(apl-test + "rank tally⍤1 row tallies shape" + (sh (apl-rank apl-tally 1 (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 2)) + +(apl-test + "rank neg⍤0 vector scalar cells" + (rv (apl-rank apl-neg-m 0 (make-array (list 3) (list 1 2 3)))) + (list -1 -2 -3)) + +(apl-test + "rank neg⍤0 vector preserves shape" + (sh (apl-rank apl-neg-m 0 (make-array (list 3) (list 1 2 3)))) + (list 3)) + +(apl-test + "rank neg⍤1 matrix per-row" + (rv (apl-rank apl-neg-m 1 (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list -1 -2 -3 -4 -5 -6)) + +(apl-test + "rank neg⍤1 matrix preserves shape" + (sh (apl-rank apl-neg-m 1 (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 2 3)) + +(apl-test + "rank k>=rank fallthrough" + (rv (apl-rank apl-tally 5 (make-array (list 4) (list 1 2 3 4)))) + (list 4)) + +(apl-test + "rank tally⍤2 whole matrix tally" + (rv + (apl-rank + apl-tally + 2 + (make-array (list 3 5) (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))) + (list 3)) + +(apl-test + "rank reverse⍤1 matrix reverse rows" + (rv (apl-rank apl-reverse 1 (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 3 2 1 6 5 4)) + +(apl-test + "rank tally⍤1 3x4 row tallies" + (rv + (apl-rank + apl-tally + 1 + (make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12)))) + (list 4 4 4)) + +(apl-test + "at-replace single index" + (rv + (apl-at-replace + (apl-scalar 99) + (make-array (list 1) (list 2)) + (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 99 3 4 5)) + +(apl-test + "at-replace multiple indices vector vals" + (rv + (apl-at-replace + (make-array (list 2) (list 99 88)) + (make-array (list 2) (list 2 4)) + (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 99 3 88 5)) + +(apl-test + "at-replace scalar broadcast" + (rv + (apl-at-replace + (apl-scalar 0) + (make-array (list 3) (list 1 3 5)) + (make-array (list 5) (list 10 20 30 40 50)))) + (list 0 20 0 40 0)) + +(apl-test + "at-replace preserves shape" + (sh + (apl-at-replace + (apl-scalar 99) + (make-array (list 1) (list 2)) + (make-array (list 5) (list 1 2 3 4 5)))) + (list 5)) + +(apl-test + "at-replace last index" + (rv + (apl-at-replace + (apl-scalar 99) + (make-array (list 1) (list 5)) + (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 2 3 4 99)) + +(apl-test + "at-replace on matrix linear-index" + (rv + (apl-at-replace + (apl-scalar 99) + (make-array (list 1) (list 3)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 2 99 4 5 6)) + +(apl-test + "at-apply negate at indices" + (rv + (apl-at-apply + apl-neg-m + (make-array (list 3) (list 1 3 5)) + (make-array (list 5) (list 1 2 3 4 5)))) + (list -1 2 -3 4 -5)) + +(apl-test + "at-apply double at index 1" + (rv + (apl-at-apply + (fn (a) (apl-mul a (apl-scalar 2))) + (make-array (list 1) (list 1)) + (make-array (list 2) (list 5 10)))) + (list 10 10)) + +(apl-test + "at-apply preserves shape" + (sh + (apl-at-apply + apl-neg-m + (make-array (list 2) (list 1 3)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 2 3)) + +(apl-test + "at-apply on matrix linear-index" + (rv + (apl-at-apply + apl-neg-m + (make-array (list 2) (list 1 6)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list -1 2 3 4 5 -6)) \ No newline at end of file diff --git a/lib/apl/tests/parse.sx b/lib/apl/tests/parse.sx new file mode 100644 index 00000000..a6d36f7d --- /dev/null +++ b/lib/apl/tests/parse.sx @@ -0,0 +1,340 @@ +(define apl-test-count 0) +(define apl-test-pass 0) +(define apl-test-fails (list)) + +(define apl-test + (fn (name actual expected) + (begin + (set! apl-test-count (+ apl-test-count 1)) + (if (= actual expected) + (set! apl-test-pass (+ apl-test-pass 1)) + (append! apl-test-fails {:name name :actual actual :expected expected}))))) + +(define tok-types + (fn (src) + (map (fn (t) (get t :type)) (apl-tokenize src)))) + +(define tok-values + (fn (src) + (map (fn (t) (get t :value)) (apl-tokenize src)))) + +(define tok-count + (fn (src) + (len (apl-tokenize src)))) + +(define tok-type-at + (fn (src i) + (get (nth (apl-tokenize src) i) :type))) + +(define tok-value-at + (fn (src i) + (get (nth (apl-tokenize src) i) :value))) + +(apl-test "empty: no tokens" (tok-count "") 0) +(apl-test "empty: whitespace only" (tok-count " ") 0) +(apl-test "num: zero" (tok-values "0") (list 0)) +(apl-test "num: positive" (tok-values "42") (list 42)) +(apl-test "num: large" (tok-values "12345") (list 12345)) +(apl-test "num: negative" (tok-values "¯5") (list -5)) +(apl-test "num: negative zero" (tok-values "¯0") (list 0)) +(apl-test "num: strand count" (tok-count "1 2 3") 3) +(apl-test "num: strand types" (tok-types "1 2 3") (list :num :num :num)) +(apl-test "num: strand values" (tok-values "1 2 3") (list 1 2 3)) +(apl-test "num: neg in strand" (tok-values "1 ¯2 3") (list 1 -2 3)) +(apl-test "str: empty" (tok-values "''") (list "")) +(apl-test "str: single char" (tok-values "'a'") (list "a")) +(apl-test "str: word" (tok-values "'hello'") (list "hello")) +(apl-test "str: escaped quote" (tok-values "''''") (list "'")) +(apl-test "str: type" (tok-types "'abc'") (list :str)) +(apl-test "name: simple" (tok-values "foo") (list "foo")) +(apl-test "name: type" (tok-types "foo") (list :name)) +(apl-test "name: mixed case" (tok-values "MyVar") (list "MyVar")) +(apl-test "name: with digits" (tok-values "x1") (list "x1")) +(apl-test "name: system var" (tok-values "⎕IO") (list "⎕IO")) +(apl-test "name: system var type" (tok-types "⎕IO") (list :name)) +(apl-test "glyph: plus" (tok-types "+") (list :glyph)) +(apl-test "glyph: plus value" (tok-values "+") (list "+")) +(apl-test "glyph: iota" (tok-values "⍳") (list "⍳")) +(apl-test "glyph: reduce" (tok-values "+/") (list "+" "/")) +(apl-test "glyph: floor" (tok-values "⌊") (list "⌊")) +(apl-test "glyph: rho" (tok-values "⍴") (list "⍴")) +(apl-test "glyph: alpha omega" (tok-types "⍺ ⍵") (list :glyph :glyph)) +(apl-test "punct: lparen" (tok-types "(") (list :lparen)) +(apl-test "punct: rparen" (tok-types ")") (list :rparen)) +(apl-test "punct: brackets" (tok-types "[42]") (list :lbracket :num :rbracket)) +(apl-test "punct: braces" (tok-types "{}") (list :lbrace :rbrace)) +(apl-test "punct: semi" (tok-types ";") (list :semi)) +(apl-test "assign: arrow" (tok-types "x←1") (list :name :assign :num)) +(apl-test "diamond: separator" (tok-types "1⋄2") (list :num :diamond :num)) +(apl-test "newline: emitted" (tok-types "1\n2") (list :num :newline :num)) +(apl-test "comment: skipped" (tok-count "⍝ ignore me") 0) +(apl-test "comment: rest ignored" (tok-count "1 ⍝ note") 1) +(apl-test "colon: bare" (tok-types ":") (list :colon)) +(apl-test "keyword: If" (tok-values ":If") (list ":If")) +(apl-test "keyword: type" (tok-types ":While") (list :keyword)) +(apl-test "keyword: EndFor" (tok-values ":EndFor") (list ":EndFor")) +(apl-test "expr: +/ ⍳ 5" (tok-types "+/ ⍳ 5") (list :glyph :glyph :glyph :num)) +(apl-test "expr: x←42" (tok-count "x←42") 3) +(apl-test "expr: dfn body" (tok-types "{⍺+⍵}") + (list :lbrace :glyph :glyph :glyph :rbrace)) + +(define apl-tokenize-test-summary + (str "tokenizer " apl-test-pass "/" apl-test-count + (if (= (len apl-test-fails) 0) "" (str " FAILS: " apl-test-fails)))) + +; =========================================================================== +; Parser tests +; =========================================================================== + +; Helper: parse an APL source string and return the AST +(define parse + (fn (src) (parse-apl src))) + +; Helper: build an expected AST node using keyword-tagged lists +(define num-node (fn (n) (list :num n))) +(define str-node (fn (s) (list :str s))) +(define name-node (fn (n) (list :name n))) +(define fn-node (fn (g) (list :fn-glyph g))) +(define fn-nm (fn (n) (list :fn-name n))) +(define assign-node (fn (nm expr) (list :assign nm expr))) +(define monad-node (fn (f a) (list :monad f a))) +(define dyad-node (fn (f l r) (list :dyad f l r))) +(define derived-fn (fn (op f) (list :derived-fn op f))) +(define derived-fn2 (fn (op f g) (list :derived-fn2 op f g))) +(define outer-node (fn (f) (list :outer "∘." f))) +(define guard-node (fn (c e) (list :guard c e))) + +; ---- numeric literals ---- + +(apl-test "parse: num literal" + (parse "42") + (num-node 42)) + +(apl-test "parse: negative num" + (parse "¯3") + (num-node -3)) + +(apl-test "parse: zero" + (parse "0") + (num-node 0)) + +; ---- string literals ---- + +(apl-test "parse: str literal" + (parse "'hello'") + (str-node "hello")) + +(apl-test "parse: empty str" + (parse "''") + (str-node "")) + +; ---- name reference ---- + +(apl-test "parse: name" + (parse "x") + (name-node "x")) + +(apl-test "parse: system name" + (parse "⎕IO") + (name-node "⎕IO")) + +; ---- strands (vec nodes) ---- + +(apl-test "parse: strand 3 nums" + (parse "1 2 3") + (list :vec (num-node 1) (num-node 2) (num-node 3))) + +(apl-test "parse: strand 2 nums" + (parse "1 2") + (list :vec (num-node 1) (num-node 2))) + +(apl-test "parse: strand with negatives" + (parse "1 ¯2 3") + (list :vec (num-node 1) (num-node -2) (num-node 3))) + +; ---- assignment ---- + +(apl-test "parse: assignment" + (parse "x←42") + (assign-node "x" (num-node 42))) + +(apl-test "parse: assignment with spaces" + (parse "x ← 42") + (assign-node "x" (num-node 42))) + +(apl-test "parse: assignment of expr" + (parse "r←2+3") + (assign-node "r" (dyad-node (fn-node "+") (num-node 2) (num-node 3)))) + +; ---- monadic functions ---- + +(apl-test "parse: monadic iota" + (parse "⍳5") + (monad-node (fn-node "⍳") (num-node 5))) + +(apl-test "parse: monadic iota with space" + (parse "⍳ 5") + (monad-node (fn-node "⍳") (num-node 5))) + +(apl-test "parse: monadic negate" + (parse "-3") + (monad-node (fn-node "-") (num-node 3))) + +(apl-test "parse: monadic floor" + (parse "⌊2") + (monad-node (fn-node "⌊") (num-node 2))) + +(apl-test "parse: monadic of name" + (parse "⍴x") + (monad-node (fn-node "⍴") (name-node "x"))) + +; ---- dyadic functions ---- + +(apl-test "parse: dyadic plus" + (parse "2+3") + (dyad-node (fn-node "+") (num-node 2) (num-node 3))) + +(apl-test "parse: dyadic times" + (parse "2×3") + (dyad-node (fn-node "×") (num-node 2) (num-node 3))) + +(apl-test "parse: dyadic with names" + (parse "x+y") + (dyad-node (fn-node "+") (name-node "x") (name-node "y"))) + +; ---- right-to-left evaluation ---- + +(apl-test "parse: right-to-left 2×3+4" + (parse "2×3+4") + (dyad-node (fn-node "×") (num-node 2) + (dyad-node (fn-node "+") (num-node 3) (num-node 4)))) + +(apl-test "parse: right-to-left chain" + (parse "1+2×3-4") + (dyad-node (fn-node "+") (num-node 1) + (dyad-node (fn-node "×") (num-node 2) + (dyad-node (fn-node "-") (num-node 3) (num-node 4))))) + +; ---- parenthesized subexpressions ---- + +(apl-test "parse: parens override order" + (parse "(2+3)×4") + (dyad-node (fn-node "×") + (dyad-node (fn-node "+") (num-node 2) (num-node 3)) + (num-node 4))) + +(apl-test "parse: nested parens" + (parse "((2+3))") + (dyad-node (fn-node "+") (num-node 2) (num-node 3))) + +(apl-test "parse: paren in dyadic right" + (parse "2×(3+4)") + (dyad-node (fn-node "×") (num-node 2) + (dyad-node (fn-node "+") (num-node 3) (num-node 4)))) + +; ---- operators → derived functions ---- + +(apl-test "parse: reduce +" + (parse "+/x") + (monad-node (derived-fn "/" (fn-node "+")) (name-node "x"))) + +(apl-test "parse: reduce iota" + (parse "+/⍳5") + (monad-node (derived-fn "/" (fn-node "+")) + (monad-node (fn-node "⍳") (num-node 5)))) + +(apl-test "parse: scan" + (parse "+\\x") + (monad-node (derived-fn "\\" (fn-node "+")) (name-node "x"))) + +(apl-test "parse: each" + (parse "⍳¨x") + (monad-node (derived-fn "¨" (fn-node "⍳")) (name-node "x"))) + +(apl-test "parse: commute" + (parse "-⍨3") + (monad-node (derived-fn "⍨" (fn-node "-")) (num-node 3))) + +(apl-test "parse: stacked ops" + (parse "+/¨x") + (monad-node (derived-fn "¨" (derived-fn "/" (fn-node "+"))) (name-node "x"))) + +; ---- outer product ---- + +(apl-test "parse: outer product monadic" + (parse "∘.×") + (outer-node (fn-node "×"))) + +(apl-test "parse: outer product dyadic names" + (parse "x ∘.× y") + (dyad-node (outer-node (fn-node "×")) (name-node "x") (name-node "y"))) + +(apl-test "parse: outer product dyadic strands" + (parse "1 2 3 ∘.× 4 5 6") + (dyad-node (outer-node (fn-node "×")) + (list :vec (num-node 1) (num-node 2) (num-node 3)) + (list :vec (num-node 4) (num-node 5) (num-node 6)))) + +; ---- inner product ---- + +(apl-test "parse: inner product" + (parse "+.×") + (derived-fn2 "." (fn-node "+") (fn-node "×"))) + +(apl-test "parse: inner product applied" + (parse "a +.× b") + (dyad-node (derived-fn2 "." (fn-node "+") (fn-node "×")) + (name-node "a") (name-node "b"))) + +; ---- dfn (anonymous function) ---- + +(apl-test "parse: simple dfn" + (parse "{⍺+⍵}") + (list :dfn (dyad-node (fn-node "+") (name-node "⍺") (name-node "⍵")))) + +(apl-test "parse: monadic dfn" + (parse "{⍵×2}") + (list :dfn (dyad-node (fn-node "×") (name-node "⍵") (num-node 2)))) + +(apl-test "parse: dfn self-ref" + (parse "{⍵≤1:1 ⋄ ⍵×∇ ⍵-1}") + (list :dfn + (guard-node (dyad-node (fn-node "≤") (name-node "⍵") (num-node 1)) (num-node 1)) + (dyad-node (fn-node "×") (name-node "⍵") + (monad-node (fn-node "∇") (dyad-node (fn-node "-") (name-node "⍵") (num-node 1)))))) + +; ---- dfn applied ---- + +(apl-test "parse: dfn as function" + (parse "{⍺+⍵} 3") + (monad-node + (list :dfn (dyad-node (fn-node "+") (name-node "⍺") (name-node "⍵"))) + (num-node 3))) + +; ---- multi-statement ---- + +(apl-test "parse: diamond separator" + (let ((result (parse "x←1 ⋄ x+2"))) + (= (first result) :program)) + true) + +(apl-test "parse: diamond first stmt" + (let ((result (parse "x←1 ⋄ x+2"))) + (nth result 1)) + (assign-node "x" (num-node 1))) + +(apl-test "parse: diamond second stmt" + (let ((result (parse "x←1 ⋄ x+2"))) + (nth result 2)) + (dyad-node (fn-node "+") (name-node "x") (num-node 2))) + +; ---- combined summary ---- + +(define apl-parse-test-count (- apl-test-count 46)) +(define apl-parse-test-pass (- apl-test-pass 46)) + +(define apl-test-summary + (str + "tokenizer 46/46 | " + "parser " apl-parse-test-pass "/" apl-parse-test-count + (if (= (len apl-test-fails) 0) "" (str " FAILS: " apl-test-fails)))) diff --git a/lib/apl/tests/pipeline.sx b/lib/apl/tests/pipeline.sx new file mode 100644 index 00000000..3ec999ea --- /dev/null +++ b/lib/apl/tests/pipeline.sx @@ -0,0 +1,314 @@ +; End-to-end pipeline tests: source string → tokenize → parse → eval-ast → array. +; Verifies the full stack as a single function call (apl-run). + +(define mkrv (fn (arr) (get arr :ravel))) +(define mksh (fn (arr) (get arr :shape))) + +; ---------- scalars ---------- + +(apl-test "apl-run \"42\" → scalar 42" (mkrv (apl-run "42")) (list 42)) + +(apl-test "apl-run \"¯7\" → scalar -7" (mkrv (apl-run "¯7")) (list -7)) + +; ---------- strands ---------- + +(apl-test + "apl-run \"1 2 3\" → vector" + (mkrv (apl-run "1 2 3")) + (list 1 2 3)) + +(apl-test "apl-run \"1 2 3\" shape" (mksh (apl-run "1 2 3")) (list 3)) + +; ---------- dyadic arithmetic ---------- + +(apl-test "apl-run \"2 + 3\" → 5" (mkrv (apl-run "2 + 3")) (list 5)) + +(apl-run "2 × 3 + 4") ; right-to-left + +(apl-test + "apl-run \"2 × 3 + 4\" → 14 (right-to-left)" + (mkrv (apl-run "2 × 3 + 4")) + (list 14)) + +(apl-test + "apl-run \"1 2 3 + 4 5 6\" → 5 7 9" + (mkrv (apl-run "1 2 3 + 4 5 6")) + (list 5 7 9)) + +(apl-test + "apl-run \"3 × 1 2 3 4\" → scalar broadcast" + (mkrv (apl-run "3 × 1 2 3 4")) + (list 3 6 9 12)) + +; ---------- monadic primitives ---------- + +(apl-test + "apl-run \"⍳5\" → 1..5" + (mkrv (apl-run "⍳5")) + (list 1 2 3 4 5)) + +(apl-test + "apl-run \"-3\" → -3 (monadic negate)" + (mkrv (apl-run "-3")) + (list -3)) + +(apl-test + "apl-run \"⌈/ 1 3 9 5 7\" → 9 (max-reduce)" + (mkrv (apl-run "⌈/ 1 3 9 5 7")) + (list 9)) + +(apl-test + "apl-run \"⌊/ 4 7 2 9 1 3\" → 1 (min-reduce)" + (mkrv (apl-run "⌊/ 4 7 2 9 1 3")) + (list 1)) + +; ---------- operators ---------- + +(apl-test "apl-run \"+/⍳5\" → 15" (mkrv (apl-run "+/⍳5")) (list 15)) + +(apl-test "apl-run \"×/⍳5\" → 120" (mkrv (apl-run "×/⍳5")) (list 120)) + +(apl-test + "apl-run \"⌈/3 1 4 1 5 9 2\" → 9" + (mkrv (apl-run "⌈/3 1 4 1 5 9 2")) + (list 9)) + +(apl-test + "apl-run \"+\\\\⍳5\" → triangular numbers" + (mkrv (apl-run "+\\⍳5")) + (list 1 3 6 10 15)) + +; ---------- outer / inner products ---------- + +(apl-test + "apl-run \"1 2 3 ∘.× 1 2 3\" → mult table values" + (mkrv (apl-run "1 2 3 ∘.× 1 2 3")) + (list 1 2 3 2 4 6 3 6 9)) + +(apl-test + "apl-run \"1 2 3 +.× 4 5 6\" → dot product 32" + (mkrv (apl-run "1 2 3 +.× 4 5 6")) + (list 32)) + +; ---------- shape ---------- + +(apl-test + "apl-run \"⍴ 1 2 3 4 5\" → 5" + (mkrv (apl-run "⍴ 1 2 3 4 5")) + (list 5)) + +(apl-test "apl-run \"⍴⍳10\" → 10" (mkrv (apl-run "⍴⍳10")) (list 10)) + +; ---------- comparison ---------- + +(apl-test "apl-run \"3 < 5\" → 1" (mkrv (apl-run "3 < 5")) (list 1)) + +(apl-test "apl-run \"5 = 5\" → 1" (mkrv (apl-run "5 = 5")) (list 1)) + +(apl-test + "apl-run \"1 2 3 = 1 0 3\" → 1 0 1" + (mkrv (apl-run "1 2 3 = 1 0 3")) + (list 1 0 1)) + +; ---------- famous one-liners ---------- + +(apl-test + "apl-run \"+/(⍳10)\" → sum 1..10 = 55" + (mkrv (apl-run "+/(⍳10)")) + (list 55)) + +(apl-test + "apl-run \"×/⍳10\" → 10! = 3628800" + (mkrv (apl-run "×/⍳10")) + (list 3628800)) + +(apl-test "apl-run \"⎕IO\" → 1" (mkrv (apl-run "⎕IO")) (list 1)) + +(apl-test "apl-run \"⎕ML\" → 1" (mkrv (apl-run "⎕ML")) (list 1)) + +(apl-test "apl-run \"⎕FR\" → 1248" (mkrv (apl-run "⎕FR")) (list 1248)) + +(apl-test "apl-run \"⎕TS\" shape (7)" (mksh (apl-run "⎕TS")) (list 7)) + +(apl-test "apl-run \"⎕FMT 42\" → \"42\"" (apl-run "⎕FMT 42") "42") + +(apl-test + "apl-run \"⎕FMT 1 2 3\" → \"1 2 3\"" + (apl-run "⎕FMT 1 2 3") + "1 2 3") + +(apl-test + "apl-run \"⎕FMT ⍳5\" → \"1 2 3 4 5\"" + (apl-run "⎕FMT ⍳5") + "1 2 3 4 5") + +(apl-test "apl-run \"⎕IO + 4\" → 5" (mkrv (apl-run "⎕IO + 4")) (list 5)) + +(apl-test + "apl-run \"(10 20 30 40 50)[3]\" → 30" + (mkrv (apl-run "(10 20 30 40 50)[3]")) + (list 30)) + +(apl-test + "apl-run \"(⍳10)[5]\" → 5" + (mkrv (apl-run "(⍳10)[5]")) + (list 5)) + +(apl-test + "apl-run \"A ← 100 200 300 ⋄ A[2]\" → 200" + (mkrv (apl-run "A ← 100 200 300 ⋄ A[2]")) + (list 200)) + +(apl-test + "apl-run \"V ← ⍳10 ⋄ V[3]\" → 3" + (mkrv (apl-run "V ← ⍳10 ⋄ V[3]")) + (list 3)) + +(apl-test + "apl-run \"(10 20 30)[1]\" → 10 (1-indexed)" + (mkrv (apl-run "(10 20 30)[1]")) + (list 10)) + +(apl-test + "apl-run \"V ← 10 20 30 40 50 ⋄ V[3] + 1\" → 31" + (mkrv (apl-run "V ← 10 20 30 40 50 ⋄ V[3] + 1")) + (list 31)) + +(apl-test + "apl-run \"(⍳5)[3] × 7\" → 21" + (mkrv (apl-run "(⍳5)[3] × 7")) + (list 21)) + +(apl-test "decimal: 3.7 → 3.7" (mkrv (apl-run "3.7")) (list 3.7)) + +(apl-test "decimal: ¯2.5 → -2.5" (mkrv (apl-run "¯2.5")) (list -2.5)) + +(apl-test "decimal: 1.5 + 2.5 → 4" (mkrv (apl-run "1.5 + 2.5")) (list 4)) + +(apl-test "decimal: ⌊3.7 → 3" (mkrv (apl-run "⌊ 3.7")) (list 3)) + +(apl-test "decimal: ⌈3.7 → 4" (mkrv (apl-run "⌈ 3.7")) (list 4)) + +(apl-test + "⎕← scalar passthrough" + (mkrv (apl-run "⎕← 42")) + (list 42)) + +(apl-test + "⎕← vector passthrough" + (mkrv (apl-run "⎕← 1 2 3")) + (list 1 2 3)) + +(apl-test + "string: 'abc' → 3-char vector" + (mkrv (apl-run "'abc'")) + (list "a" "b" "c")) + +(apl-test "string: 'a' is rank-0 scalar" (mksh (apl-run "'a'")) (list)) + +(apl-test "string: 'hello' shape (5)" (mksh (apl-run "'hello'")) (list 5)) + +(apl-test + "named-fn: f ← {⍺+⍵} ⋄ 3 f 4 → 7" + (mkrv (apl-run "f ← {⍺+⍵} ⋄ 3 f 4")) + (list 7)) + +(apl-test + "named-fn monadic: sq ← {⍵×⍵} ⋄ sq 7 → 49" + (mkrv (apl-run "sq ← {⍵×⍵} ⋄ sq 7")) + (list 49)) + +(apl-test + "named-fn dyadic: hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4 → 25" + (mkrv (apl-run "hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4")) + (list 25)) + +(apl-test + "named-fn: dbl ← {⍵+⍵} ⋄ dbl ⍳5" + (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ dbl ⍳5")) + (list 2 4 6 8 10)) + +(apl-test + "named-fn factorial via ∇ recursion" + (mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5")) + (list 120)) + +(apl-test + "named-fn used twice in expr: dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4" + (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4")) + (list 14)) + +(apl-test + "named-fn with vector arg: neg ← {-⍵} ⋄ neg 1 2 3" + (mkrv (apl-run "neg ← {-⍵} ⋄ neg 1 2 3")) + (list -1 -2 -3)) + +(apl-test + "multi-axis: M[2;2] → center" + (mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[2;2]")) + (list 5)) + +(apl-test + "multi-axis: M[1;] → first row" + (mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]")) + (list 1 2 3)) + +(apl-test + "multi-axis: M[;2] → second column" + (mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[;2]")) + (list 2 5 8)) + +(apl-test + "multi-axis: M[1 2;1 2] → 2x2 block" + (mkrv (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]")) + (list 1 2 4 5)) + +(apl-test + "multi-axis: M[1 2;1 2] shape (2 2)" + (mksh (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]")) + (list 2 2)) + +(apl-test + "multi-axis: M[;] full matrix" + (mkrv (apl-run "M ← (2 2) ⍴ 10 20 30 40 ⋄ M[;]")) + (list 10 20 30 40)) + +(apl-test + "multi-axis: M[1;] shape collapsed" + (mksh (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]")) + (list 3)) + +(apl-test + "multi-axis: select all rows of column 3" + (mkrv (apl-run "M ← (4 3) ⍴ 1 2 3 4 5 6 7 8 9 10 11 12 ⋄ M[;3]")) + (list 3 6 9 12)) + +(apl-test + "train: mean = (+/÷≢) on 1..5" + (mkrv (apl-run "(+/÷≢) 1 2 3 4 5")) + (list 3)) + +(apl-test + "train: mean of 2 4 6 8 10" + (mkrv (apl-run "(+/÷≢) 2 4 6 8 10")) + (list 6)) + +(apl-test + "train 2-atop: (- ⌊) 5 → -5" + (mkrv (apl-run "(- ⌊) 5")) + (list -5)) + +(apl-test + "train 3-fork dyadic: 2(+×-)5 → -21" + (mkrv (apl-run "2 (+ × -) 5")) + (list -21)) + +(apl-test + "train: range = (⌈/-⌊/) on vector" + (mkrv (apl-run "(⌈/-⌊/) 3 1 4 1 5 9 2 6")) + (list 8)) + +(apl-test + "train: mean of ⍳10 has shape ()" + (mksh (apl-run "(+/÷≢) ⍳10")) + (list)) diff --git a/lib/apl/tests/programs-e2e.sx b/lib/apl/tests/programs-e2e.sx new file mode 100644 index 00000000..33ff6b29 --- /dev/null +++ b/lib/apl/tests/programs-e2e.sx @@ -0,0 +1,96 @@ +; End-to-end tests of the classic-program archetypes — running APL +; source through the full pipeline (tokenize → parse → eval-ast → runtime). +; +; These mirror the algorithms documented in lib/apl/tests/programs/*.apl +; but use forms our pipeline supports today (named functions instead of +; the inline ⍵← rebinding idiom; multi-stmt over single one-liners). + +(define mkrv (fn (arr) (get arr :ravel))) +(define mksh (fn (arr) (get arr :shape))) + +; ---------- factorial via ∇ recursion (cf. n-queens style) ---------- + +(apl-test + "e2e: factorial 5! = 120" + (mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5")) + (list 120)) + +(apl-test + "e2e: factorial 7! = 5040" + (mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 7")) + (list 5040)) + +(apl-test + "e2e: factorial via ×/⍳N (no recursion)" + (mkrv (apl-run "fact ← {×/⍳⍵} ⋄ fact 6")) + (list 720)) + +; ---------- sum / triangular numbers (sum-1..N) ---------- + +(apl-test + "e2e: triangular(10) = 55" + (mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 10")) + (list 55)) + +(apl-test + "e2e: triangular(100) = 5050" + (mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 100")) + (list 5050)) + +; ---------- sum of squares ---------- + +(apl-test + "e2e: sum-of-squares 1..5 = 55" + (mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳5")) + (list 55)) + +(apl-test + "e2e: sum-of-squares 1..10 = 385" + (mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳10")) + (list 385)) + +; ---------- divisor-counting (prime-sieve building blocks) ---------- + +(apl-test + "e2e: divisor counts 1..5 via outer mod" + (mkrv (apl-run "P ← ⍳ 5 ⋄ +⌿ 0 = P ∘.| P")) + (list 1 2 2 3 2)) + +(apl-test + "e2e: divisor counts 1..10" + (mkrv (apl-run "P ← ⍳ 10 ⋄ +⌿ 0 = P ∘.| P")) + (list 1 2 2 3 2 4 2 4 3 4)) + +(apl-test + "e2e: prime-mask 1..10 (count==2)" + (mkrv (apl-run "P ← ⍳ 10 ⋄ 2 = +⌿ 0 = P ∘.| P")) + (list 0 1 1 0 1 0 1 0 0 0)) + +; ---------- monadic primitives chained ---------- + +(apl-test + "e2e: sum of |abs| = 15" + (mkrv (apl-run "+/|¯1 ¯2 ¯3 ¯4 ¯5")) + (list 15)) + +(apl-test + "e2e: max of squares 1..6" + (mkrv (apl-run "⌈/(⍳6)×⍳6")) + (list 36)) + +; ---------- nested named functions ---------- + +(apl-test + "e2e: compose dbl and sq via two named fns" + (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ sq ← {⍵×⍵} ⋄ sq dbl 3")) + (list 36)) + +(apl-test + "e2e: max-of-two as named dyadic fn" + (mkrv (apl-run "mx ← {⍺⌈⍵} ⋄ 5 mx 3")) + (list 5)) + +(apl-test + "e2e: sqrt-via-newton 1 step from 1 → 2.5" + (mkrv (apl-run "step ← {(⍵+⍺÷⍵)÷2} ⋄ 4 step 1")) + (list 2.5)) diff --git a/lib/apl/tests/programs.sx b/lib/apl/tests/programs.sx new file mode 100644 index 00000000..7d97976a --- /dev/null +++ b/lib/apl/tests/programs.sx @@ -0,0 +1,306 @@ +; Tests for classic APL programs (lib/apl/tests/programs/*.apl). +; Programs are showcase APL source; runtime impl is in lib/apl/runtime.sx. + +(define mkrv (fn (arr) (get arr :ravel))) +(define mksh (fn (arr) (get arr :shape))) + +; ===== primes (Sieve of Eratosthenes) ===== + +(apl-test "primes 1 → empty" (mkrv (apl-primes 1)) (list)) + +(apl-test "primes 2 → just 2" (mkrv (apl-primes 2)) (list 2)) + +(apl-test "primes 10 → 2 3 5 7" (mkrv (apl-primes 10)) (list 2 3 5 7)) + +(apl-test + "primes 20 → 2 3 5 7 11 13 17 19" + (mkrv (apl-primes 20)) + (list 2 3 5 7 11 13 17 19)) + +(apl-test + "primes 30" + (mkrv (apl-primes 30)) + (list 2 3 5 7 11 13 17 19 23 29)) + +(apl-test + "primes 50" + (mkrv (apl-primes 50)) + (list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47)) + +(apl-test "primes 7 length" (first (mksh (apl-primes 7))) 4) + +(apl-test "primes 100 has 25 primes" (first (mksh (apl-primes 100))) 25) + +; ===== compress helper sanity ===== + +(apl-test + "compress 1 0 1 0 1 / 10 20 30 40 50" + (mkrv + (apl-compress + (make-array (list 5) (list 1 0 1 0 1)) + (make-array (list 5) (list 10 20 30 40 50)))) + (list 10 30 50)) + +(apl-test + "compress all-zero mask → empty" + (mkrv + (apl-compress + (make-array (list 3) (list 0 0 0)) + (make-array (list 3) (list 1 2 3)))) + (list)) + +(apl-test + "compress all-one mask → full vector" + (mkrv + (apl-compress + (make-array (list 3) (list 1 1 1)) + (make-array (list 3) (list 1 2 3)))) + (list 1 2 3)) + +(apl-test + "life: empty 5x5 stays empty" + (mkrv + (apl-life-step + (make-array + (list 5 5) + (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))) + (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) + +(apl-test + "life: horizontal blinker → vertical blinker" + (mkrv + (apl-life-step + (make-array + (list 5 5) + (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))) + (list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0)) + +(apl-test + "life: vertical blinker → horizontal blinker" + (mkrv + (apl-life-step + (make-array + (list 5 5) + (list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0)))) + (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0)) + +(apl-test + "life: blinker has period 2" + (mkrv + (apl-life-step + (apl-life-step + (make-array + (list 5 5) + (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))))) + (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0)) + +(apl-test + "life: 2x2 block stable on 5x5" + (mkrv + (apl-life-step + (make-array + (list 5 5) + (list 0 0 0 0 0 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0)))) + (list 0 0 0 0 0 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0)) + +(apl-test + "life: shape preserved" + (mksh + (apl-life-step + (make-array + (list 5 5) + (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))) + (list 5 5)) + +(apl-test + "life: glider on 6x6 advances" + (mkrv + (apl-life-step + (make-array + (list 6 6) + (list + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0)))) + (list + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 0 + 0 + 0 + 0 + 1 + 1 + 0 + 0 + 0 + 0 + 1 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0)) + +(apl-test + "mandelbrot c=0 stays bounded" + (mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0)) 100)) + (list 100)) + +(apl-test + "mandelbrot c=-1 cycle bounded" + (mkrv (apl-mandelbrot-1d (make-array (list 1) (list -1)) 100)) + (list 100)) + +(apl-test + "mandelbrot c=-2 boundary stays bounded" + (mkrv (apl-mandelbrot-1d (make-array (list 1) (list -2)) 100)) + (list 100)) + +(apl-test + "mandelbrot c=0.25 boundary stays bounded" + (mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0.25)) 100)) + (list 100)) + +(apl-test + "mandelbrot c=1 escapes at iter 3" + (mkrv (apl-mandelbrot-1d (make-array (list 1) (list 1)) 100)) + (list 3)) + +(apl-test + "mandelbrot c=0.5 escapes at iter 5" + (mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0.5)) 100)) + (list 5)) + +(apl-test + "mandelbrot batched grid (rank-polymorphic)" + (mkrv (apl-mandelbrot-1d (make-array (list 5) (list -2 -1 0 1 2)) 10)) + (list 10 10 10 3 2)) + +(apl-test + "mandelbrot batched preserves shape" + (mksh (apl-mandelbrot-1d (make-array (list 5) (list -2 -1 0 1 2)) 10)) + (list 5)) + +(apl-test + "mandelbrot c=-1.5 stays bounded" + (mkrv (apl-mandelbrot-1d (make-array (list 1) (list -1.5)) 100)) + (list 100)) + +(apl-test "queens 1 → 1 solution" (mkrv (apl-queens 1)) (list 1)) + +(apl-test "queens 2 → 0 solutions" (mkrv (apl-queens 2)) (list 0)) + +(apl-test "queens 3 → 0 solutions" (mkrv (apl-queens 3)) (list 0)) + +(apl-test "queens 4 → 2 solutions" (mkrv (apl-queens 4)) (list 2)) + +(apl-test "queens 5 → 10 solutions" (mkrv (apl-queens 5)) (list 10)) + +(apl-test "queens 6 → 4 solutions" (mkrv (apl-queens 6)) (list 4)) + +(apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40)) + +(apl-test "queens 8 → 92 solutions" (mkrv (apl-queens 8)) (list 92)) + +(apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6) + +(apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24) + +(apl-test + "quicksort empty" + (mkrv (apl-quicksort (make-array (list 0) (list)))) + (list)) + +(apl-test + "quicksort single" + (mkrv (apl-quicksort (make-array (list 1) (list 42)))) + (list 42)) + +(apl-test + "quicksort already sorted" + (mkrv (apl-quicksort (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 2 3 4 5)) + +(apl-test + "quicksort reverse sorted" + (mkrv (apl-quicksort (make-array (list 5) (list 5 4 3 2 1)))) + (list 1 2 3 4 5)) + +(apl-test + "quicksort with duplicates" + (mkrv (apl-quicksort (make-array (list 7) (list 3 1 4 1 5 9 2)))) + (list 1 1 2 3 4 5 9)) + +(apl-test + "quicksort all equal" + (mkrv (apl-quicksort (make-array (list 5) (list 7 7 7 7 7)))) + (list 7 7 7 7 7)) + +(apl-test + "quicksort negatives" + (mkrv (apl-quicksort (make-array (list 5) (list -3 1 -1 2 0)))) + (list -3 -1 0 1 2)) + +(apl-test + "quicksort 11-element pi" + (mkrv + (apl-quicksort (make-array (list 11) (list 3 1 4 1 5 9 2 6 5 3 5)))) + (list 1 1 2 3 3 4 5 5 5 6 9)) + +(apl-test + "quicksort preserves length" + (first + (mksh (apl-quicksort (make-array (list 7) (list 3 1 4 1 5 9 2))))) + 7) diff --git a/lib/apl/tests/programs/life.apl b/lib/apl/tests/programs/life.apl new file mode 100644 index 00000000..b461d544 --- /dev/null +++ b/lib/apl/tests/programs/life.apl @@ -0,0 +1,22 @@ +⍝ Conway's Game of Life — toroidal one-liner +⍝ +⍝ The classic Roger Hui formulation: +⍝ life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} +⍝ +⍝ Read right-to-left: +⍝ ⊂⍵ : enclose the board (so it's a single scalar item) +⍝ ¯1 0 1 ⌽¨ ⊂⍵ : produce 3 horizontally-shifted copies +⍝ ¯1 0 1 ∘.⊖ … : outer-product with vertical shifts → 3×3 = 9 shifts +⍝ +/ +/ … : sum the 9 boards element-wise → neighbor-count + self +⍝ 3 4 = … : boolean — count is exactly 3 or exactly 4 +⍝ 1 ⍵ ∨.∧ … : "alive next" iff (count=3) or (alive AND count=4) +⍝ ⊃ … : disclose back to a 2D board +⍝ +⍝ Rules in plain language: +⍝ - dead cell + 3 live neighbors → born +⍝ - live cell + 2 or 3 live neighbors → survives +⍝ - all else → dies +⍝ +⍝ Toroidal: edges wrap (rotate is cyclic). + +life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} diff --git a/lib/apl/tests/programs/mandelbrot.apl b/lib/apl/tests/programs/mandelbrot.apl new file mode 100644 index 00000000..03bfad4e --- /dev/null +++ b/lib/apl/tests/programs/mandelbrot.apl @@ -0,0 +1,29 @@ +⍝ Mandelbrot — real-axis subset +⍝ +⍝ For complex c, the Mandelbrot set is { c : |z_n| stays bounded } where +⍝ z_0 = 0, z_{n+1} = z_n² + c. +⍝ Restricting c (and z) to ℝ gives the segment c ∈ [-2, 1/4] +⍝ where the iteration stays bounded. +⍝ +⍝ Rank-polymorphic batched-iteration form: +⍝ mandelbrot ← {⍵ ⍵⍵ ⍺⍺ +,(⍺⍺ × ⍺⍺) } +⍝ +⍝ Pseudocode (as we don't have ⎕ system fns yet): +⍝ z ← 0×c ⍝ start at zero +⍝ alive ← 1+0×c ⍝ all "still in" +⍝ for k iterations: +⍝ alive ← alive ∧ 4 ≥ z×z ⍝ still bounded? +⍝ z ← alive × c + z×z ⍝ freeze escaped via mask +⍝ count ← count + alive ⍝ tally surviving iters +⍝ +⍝ Examples (count after 100 iterations): +⍝ c=0 : 100 (z stays at 0) +⍝ c=-1 : 100 (cycles 0,-1,0,-1,...) +⍝ c=-2 : 100 (settles at 2 — boundary) +⍝ c=0.25 : 100 (boundary — converges to 0.5) +⍝ c=0.5 : 5 (escapes by iteration 6) +⍝ c=1 : 3 (escapes quickly) +⍝ +⍝ Real-axis Mandelbrot set: bounded for c ∈ [-2, 0.25]. + +mandelbrot ← {z←alive←count←0×⍵ ⋄ {alive←alive∧4≥z×z ⋄ z←alive×⍵+z×z ⋄ count+←alive}⍣⍺⊢⍵} diff --git a/lib/apl/tests/programs/n-queens.apl b/lib/apl/tests/programs/n-queens.apl new file mode 100644 index 00000000..fc52abcd --- /dev/null +++ b/lib/apl/tests/programs/n-queens.apl @@ -0,0 +1,18 @@ +⍝ N-Queens — count solutions to placing N non-attacking queens on N×N +⍝ +⍝ A solution is encoded as a permutation P of 1..N where P[i] is the +⍝ column of the queen in row i. Rows and columns are then automatically +⍝ unique (it's a permutation). We must additionally rule out queens +⍝ sharing a diagonal: |i-j| = |P[i]-P[j]| for any pair. +⍝ +⍝ Backtracking via reduce — the classic Roger Hui style: +⍝ queens ← {≢{⍵,¨⍨↓(0=∊(¨⍳⍴⍵)≠.+|⍵)/⍳⍴⍵}/(⍳⍵)⍴⊂⍳⍵} +⍝ +⍝ Plain reading: +⍝ permute 1..N, keep those where no two queens share a diagonal. +⍝ +⍝ Known solution counts (OEIS A000170): +⍝ N 1 2 3 4 5 6 7 8 9 10 +⍝ q(N) 1 0 0 2 10 4 40 92 352 724 + +queens ← {≢({(i j)←⍺⍵ ⋄ (|i-j)≠|(P[i])-(P[j])}⌿permutations ⍵)} diff --git a/lib/apl/tests/programs/primes.apl b/lib/apl/tests/programs/primes.apl new file mode 100644 index 00000000..4afd9f2a --- /dev/null +++ b/lib/apl/tests/programs/primes.apl @@ -0,0 +1,16 @@ +⍝ Sieve of Eratosthenes — the classic APL one-liner +⍝ primes ← (2=+⌿0=A∘.|A)/A←⍳N +⍝ +⍝ Read right-to-left: +⍝ A ← ⍳N : A is 1..N +⍝ A∘.|A : outer-product residue table — M[i,j] = A[j] mod A[i] +⍝ 0=... : boolean — true where A[i] divides A[j] +⍝ +⌿... : column sums — count of divisors per A[j] +⍝ 2=... : true for numbers with exactly 2 divisors (1 and self) → primes +⍝ .../A : compress — select A[j] where mask[j] is true +⍝ +⍝ Examples: +⍝ primes 10 → 2 3 5 7 +⍝ primes 30 → 2 3 5 7 11 13 17 19 23 29 + +primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} diff --git a/lib/apl/tests/programs/quicksort.apl b/lib/apl/tests/programs/quicksort.apl new file mode 100644 index 00000000..c9dd345d --- /dev/null +++ b/lib/apl/tests/programs/quicksort.apl @@ -0,0 +1,25 @@ +⍝ Quicksort — the classic Roger Hui one-liner +⍝ +⍝ Q ← {1≥≢⍵:⍵ ⋄ (∇⍵⌿⍨⍵p←⍵⌷⍨?≢⍵} +⍝ +⍝ Read right-to-left: +⍝ ?≢⍵ : pick a random index in 1..length +⍝ ⍵⌷⍨… : take that element as pivot p +⍝ ⍵>p : boolean — elements greater than pivot +⍝ ∇⍵⌿⍨… : recursively sort the > partition +⍝ (p=⍵)/⍵ : keep elements equal to pivot +⍝ ⍵

p} 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/apl/tests/scalar.sx b/lib/apl/tests/scalar.sx new file mode 100644 index 00000000..26a2c1e2 --- /dev/null +++ b/lib/apl/tests/scalar.sx @@ -0,0 +1,369 @@ +; APL scalar primitives test suite +; Requires: lib/apl/runtime.sx + +; ============================================================ +; Test framework +; ============================================================ + +(define apl-rt-count 0) +(define apl-rt-pass 0) +(define apl-rt-fails (list)) + +; Element-wise list comparison (handles both List and ListRef) +(define + lists-eq + (fn + (a b) + (if + (and (= (len a) 0) (= (len b) 0)) + true + (if + (not (= (len a) (len b))) + false + (if + (not (= (first a) (first b))) + false + (lists-eq (rest a) (rest b))))))) + +(define + apl-rt-test + (fn + (name actual expected) + (begin + (set! apl-rt-count (+ apl-rt-count 1)) + (if + (equal? actual expected) + (set! apl-rt-pass (+ apl-rt-pass 1)) + (append! apl-rt-fails {:actual actual :expected expected :name name}))))) + +; Test that a ravel equals a plain list (handles ListRef vs List) +(define + ravel-test + (fn + (name arr expected-list) + (begin + (set! apl-rt-count (+ apl-rt-count 1)) + (let + ((actual (get arr :ravel))) + (if + (lists-eq actual expected-list) + (set! apl-rt-pass (+ apl-rt-pass 1)) + (append! apl-rt-fails {:actual actual :expected expected-list :name name})))))) + +; Test a scalar ravel value (single-element list) +(define + scalar-test + (fn (name arr expected-val) (ravel-test name arr (list expected-val)))) + +; ============================================================ +; Array constructor tests +; ============================================================ + +(apl-rt-test + "scalar: shape is empty list" + (get (apl-scalar 5) :shape) + (list)) + +(apl-rt-test + "scalar: ravel has one element" + (get (apl-scalar 5) :ravel) + (list 5)) + +(apl-rt-test "scalar: rank 0" (array-rank (apl-scalar 5)) 0) + +(apl-rt-test "scalar? returns true for scalar" (scalar? (apl-scalar 5)) true) + +(apl-rt-test "scalar: zero" (get (apl-scalar 0) :ravel) (list 0)) + +(apl-rt-test + "vector: shape is (3)" + (get (apl-vector (list 1 2 3)) :shape) + (list 3)) + +(apl-rt-test + "vector: ravel matches input" + (get (apl-vector (list 1 2 3)) :ravel) + (list 1 2 3)) + +(apl-rt-test "vector: rank 1" (array-rank (apl-vector (list 1 2 3))) 1) + +(apl-rt-test + "scalar? returns false for vector" + (scalar? (apl-vector (list 1 2 3))) + false) + +(apl-rt-test + "make-array: rank 2" + (array-rank (make-array (list 2 3) (list 1 2 3 4 5 6))) + 2) + +(apl-rt-test + "make-array: shape" + (get (make-array (list 2 3) (list 1 2 3 4 5 6)) :shape) + (list 2 3)) + +(apl-rt-test + "array-ref: first element" + (array-ref (apl-vector (list 10 20 30)) 0) + 10) + +(apl-rt-test + "array-ref: last element" + (array-ref (apl-vector (list 10 20 30)) 2) + 30) + +(apl-rt-test "enclose: wraps in rank-0" (scalar? (enclose 42)) true) + +(apl-rt-test + "enclose: ravel contains value" + (get (enclose 42) :ravel) + (list 42)) + +(apl-rt-test "disclose: unwraps rank-0" (disclose (enclose 42)) 42) + +; ============================================================ +; Shape primitive tests +; ============================================================ + +(ravel-test "⍴ scalar: returns empty" (apl-shape (apl-scalar 5)) (list)) + +(ravel-test + "⍴ vector: returns (3)" + (apl-shape (apl-vector (list 1 2 3))) + (list 3)) + +(ravel-test + "⍴ matrix: returns (2 3)" + (apl-shape (make-array (list 2 3) (list 1 2 3 4 5 6))) + (list 2 3)) + +(ravel-test + ", ravel scalar: vector of 1" + (apl-ravel (apl-scalar 5)) + (list 5)) + +(apl-rt-test + ", ravel vector: same elements" + (get (apl-ravel (apl-vector (list 1 2 3))) :ravel) + (list 1 2 3)) + +(apl-rt-test + ", ravel matrix: all elements" + (get (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))) :ravel) + (list 1 2 3 4 5 6)) + +(scalar-test "≢ tally scalar: 1" (apl-tally (apl-scalar 5)) 1) + +(scalar-test + "≢ tally vector: first dimension" + (apl-tally (apl-vector (list 1 2 3))) + 3) + +(scalar-test + "≢ tally matrix: first dimension" + (apl-tally (make-array (list 2 3) (list 1 2 3 4 5 6))) + 2) + +(scalar-test + "≡ depth flat vector: 0" + (apl-depth (apl-vector (list 1 2 3))) + 0) + +(scalar-test "≡ depth scalar: 0" (apl-depth (apl-scalar 5)) 0) + +(scalar-test + "≡ depth nested (enclose in vector): 1" + (apl-depth (enclose (apl-vector (list 1 2 3)))) + 1) + +; ============================================================ +; ⍳ iota tests +; ============================================================ + +(apl-rt-test + "⍳5 shape is (5)" + (get (apl-iota (apl-scalar 5)) :shape) + (list 5)) + +(ravel-test "⍳5 ravel is 1..5" (apl-iota (apl-scalar 5)) (list 1 2 3 4 5)) + +(ravel-test "⍳1 ravel is (1)" (apl-iota (apl-scalar 1)) (list 1)) + +(ravel-test "⍳0 ravel is empty" (apl-iota (apl-scalar 0)) (list)) + +(apl-rt-test "apl-io is 1" apl-io 1) + +; ============================================================ +; Arithmetic broadcast tests +; ============================================================ + +(scalar-test + "+ scalar scalar: 3+4=7" + (apl-add (apl-scalar 3) (apl-scalar 4)) + 7) + +(ravel-test + "+ vector scalar: +10" + (apl-add (apl-vector (list 1 2 3)) (apl-scalar 10)) + (list 11 12 13)) + +(ravel-test + "+ scalar vector: 10+" + (apl-add (apl-scalar 10) (apl-vector (list 1 2 3))) + (list 11 12 13)) + +(ravel-test + "+ vector vector" + (apl-add (apl-vector (list 1 2 3)) (apl-vector (list 4 5 6))) + (list 5 7 9)) + +(scalar-test "- negate monadic" (apl-neg-m (apl-scalar 5)) -5) + +(scalar-test "- dyadic 10-3=7" (apl-sub (apl-scalar 10) (apl-scalar 3)) 7) + +(scalar-test "× signum positive" (apl-signum (apl-scalar 7)) 1) + +(scalar-test "× signum negative" (apl-signum (apl-scalar -3)) -1) + +(scalar-test "× signum zero" (apl-signum (apl-scalar 0)) 0) + +(scalar-test "× dyadic 3×4=12" (apl-mul (apl-scalar 3) (apl-scalar 4)) 12) + +(scalar-test "÷ reciprocal 1÷4=0.25" (apl-recip (apl-scalar 4)) 0.25) + +(scalar-test + "÷ dyadic 10÷4=2.5" + (apl-div (apl-scalar 10) (apl-scalar 4)) + 2.5) + +(scalar-test "⌈ ceiling 2.3→3" (apl-ceil (apl-scalar 2.3)) 3) + +(scalar-test "⌈ max 3 5 → 5" (apl-max (apl-scalar 3) (apl-scalar 5)) 5) + +(scalar-test "⌊ floor 2.7→2" (apl-floor (apl-scalar 2.7)) 2) + +(scalar-test "⌊ min 3 5 → 3" (apl-min (apl-scalar 3) (apl-scalar 5)) 3) + +(scalar-test "* exp monadic e^0=1" (apl-exp (apl-scalar 0)) 1) + +(scalar-test + "* pow dyadic 2^10=1024" + (apl-pow (apl-scalar 2) (apl-scalar 10)) + 1024) + +(scalar-test "⍟ ln 1=0" (apl-ln (apl-scalar 1)) 0) + +(scalar-test "| abs positive" (apl-abs (apl-scalar 5)) 5) + +(scalar-test "| abs negative" (apl-abs (apl-scalar -5)) 5) + +(scalar-test "| mod 3|7=1" (apl-mod (apl-scalar 3) (apl-scalar 7)) 1) + +(scalar-test "! factorial 5!=120" (apl-fact (apl-scalar 5)) 120) + +(scalar-test "! factorial 0!=1" (apl-fact (apl-scalar 0)) 1) + +(scalar-test + "! binomial 4 choose 2 = 6" + (apl-binomial (apl-scalar 4) (apl-scalar 2)) + 6) + +(scalar-test "○ pi×0=0" (apl-pi-times (apl-scalar 0)) 0) + +(scalar-test "○ trig sin(0)=0" (apl-trig (apl-scalar 1) (apl-scalar 0)) 0) + +(scalar-test "○ trig cos(0)=1" (apl-trig (apl-scalar 2) (apl-scalar 0)) 1) + +; ============================================================ +; Comparison tests +; ============================================================ + +(scalar-test "< less: 3<5 → 1" (apl-lt (apl-scalar 3) (apl-scalar 5)) 1) + +(scalar-test "< less: 5<3 → 0" (apl-lt (apl-scalar 5) (apl-scalar 3)) 0) + +(scalar-test + "≤ le equal: 3≤3 → 1" + (apl-le (apl-scalar 3) (apl-scalar 3)) + 1) + +(scalar-test "= eq: 5=5 → 1" (apl-eq (apl-scalar 5) (apl-scalar 5)) 1) + +(scalar-test "= ne: 5=6 → 0" (apl-eq (apl-scalar 5) (apl-scalar 6)) 0) + +(scalar-test "≥ ge: 5≥3 → 1" (apl-ge (apl-scalar 5) (apl-scalar 3)) 1) + +(scalar-test "> gt: 5>3 → 1" (apl-gt (apl-scalar 5) (apl-scalar 3)) 1) + +(scalar-test "≠ ne: 5≠3 → 1" (apl-ne (apl-scalar 5) (apl-scalar 3)) 1) + +(ravel-test + "comparison vector broadcast: 1 2 3 < 2 → 1 0 0" + (apl-lt (apl-vector (list 1 2 3)) (apl-scalar 2)) + (list 1 0 0)) + +; ============================================================ +; Logical tests +; ============================================================ + +(scalar-test "~ not 0 → 1" (apl-not (apl-scalar 0)) 1) + +(scalar-test "~ not 1 → 0" (apl-not (apl-scalar 1)) 0) + +(ravel-test + "~ not vector: 1 0 1 0 → 0 1 0 1" + (apl-not (apl-vector (list 1 0 1 0))) + (list 0 1 0 1)) + +(scalar-test + "∧ and 1∧1 → 1" + (apl-and (apl-scalar 1) (apl-scalar 1)) + 1) + +(scalar-test + "∧ and 1∧0 → 0" + (apl-and (apl-scalar 1) (apl-scalar 0)) + 0) + +(scalar-test "∨ or 0∨1 → 1" (apl-or (apl-scalar 0) (apl-scalar 1)) 1) + +(scalar-test "∨ or 0∨0 → 0" (apl-or (apl-scalar 0) (apl-scalar 0)) 0) + +(scalar-test + "⍱ nor 0⍱0 → 1" + (apl-nor (apl-scalar 0) (apl-scalar 0)) + 1) + +(scalar-test + "⍱ nor 1⍱0 → 0" + (apl-nor (apl-scalar 1) (apl-scalar 0)) + 0) + +(scalar-test + "⍲ nand 1⍲1 → 0" + (apl-nand (apl-scalar 1) (apl-scalar 1)) + 0) + +(scalar-test + "⍲ nand 1⍲0 → 1" + (apl-nand (apl-scalar 1) (apl-scalar 0)) + 1) + +; ============================================================ +; plus-m identity test +; ============================================================ + +(scalar-test "+ monadic identity: +5 → 5" (apl-plus-m (apl-scalar 5)) 5) + +; ============================================================ +; Summary +; ============================================================ + +(define + apl-scalar-summary + (str + "scalar " + apl-rt-pass + "/" + apl-rt-count + (if (= (len apl-rt-fails) 0) "" (str " FAILS: " apl-rt-fails)))) diff --git a/lib/apl/tests/structural.sx b/lib/apl/tests/structural.sx new file mode 100644 index 00000000..03c28a53 --- /dev/null +++ b/lib/apl/tests/structural.sx @@ -0,0 +1,608 @@ +;; lib/apl/tests/structural.sx — Phase 3: structural primitives +;; Tests for: apl-reshape, apl-ravel, apl-transpose, apl-transpose-dyadic +;; Loaded after runtime.sx; shares apl-test / apl-test-pass / apl-test-fail. + +(define rv (fn (arr) (get arr :ravel))) +(define sh (fn (arr) (get arr :shape))) + +;; --------------------------------------------------------------------------- +;; 1. Ravel (monadic ,) +;; --------------------------------------------------------------------------- +(apl-test "ravel scalar" (rv (apl-ravel (apl-scalar 5))) (list 5)) + +(apl-test + "ravel vector" + (rv (apl-ravel (make-array (list 3) (list 1 2 3)))) + (list 1 2 3)) + +(apl-test + "ravel matrix" + (rv (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 2 3 4 5 6)) + +(apl-test + "ravel shape is rank-1" + (sh (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 6)) + +;; --------------------------------------------------------------------------- +;; 2. Reshape (dyadic ⍴) +;; --------------------------------------------------------------------------- + +(apl-test + "reshape 2x3 ravel" + (rv + (apl-reshape + (make-array (list 2) (list 2 3)) + (make-array (list 6) (list 1 2 3 4 5 6)))) + (list 1 2 3 4 5 6)) + +(apl-test + "reshape 2x3 shape" + (sh + (apl-reshape + (make-array (list 2) (list 2 3)) + (make-array (list 6) (list 1 2 3 4 5 6)))) + (list 2 3)) + +(apl-test + "reshape cycle 6 from 1 2" + (rv + (apl-reshape + (make-array (list 1) (list 6)) + (make-array (list 2) (list 1 2)))) + (list 1 2 1 2 1 2)) + +(apl-test + "reshape cycle 2x3 from 1 2" + (rv + (apl-reshape + (make-array (list 2) (list 2 3)) + (make-array (list 2) (list 1 2)))) + (list 1 2 1 2 1 2)) + +(apl-test + "reshape scalar fill" + (rv (apl-reshape (make-array (list 1) (list 4)) (apl-scalar 7))) + (list 7 7 7 7)) + +(apl-test + "reshape truncate" + (rv + (apl-reshape + (make-array (list 1) (list 3)) + (make-array (list 6) (list 10 20 30 40 50 60)))) + (list 10 20 30)) + +(apl-test + "reshape matrix to vector" + (sh + (apl-reshape + (make-array (list 1) (list 6)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 6)) + +(apl-test + "reshape 2x2x3" + (sh + (apl-reshape + (make-array (list 3) (list 2 2 3)) + (make-array (list 12) (range 1 13)))) + (list 2 2 3)) + +(apl-test + "reshape to empty" + (rv + (apl-reshape + (make-array (list 1) (list 0)) + (make-array (list 3) (list 1 2 3)))) + (list)) + +;; --------------------------------------------------------------------------- +;; 3. Monadic transpose (⍉) +;; --------------------------------------------------------------------------- + +(apl-test + "transpose scalar shape" + (sh (apl-transpose (apl-scalar 99))) + (list)) + +(apl-test + "transpose scalar ravel" + (rv (apl-transpose (apl-scalar 99))) + (list 99)) + +(apl-test + "transpose vector shape" + (sh (apl-transpose (make-array (list 3) (list 3 1 4)))) + (list 3)) + +(apl-test + "transpose vector ravel" + (rv (apl-transpose (make-array (list 3) (list 3 1 4)))) + (list 3 1 4)) + +(apl-test + "transpose 2x3 shape" + (sh (apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 3 2)) + +(apl-test + "transpose 2x3 ravel" + (rv (apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 4 2 5 3 6)) + +(apl-test + "transpose 3x3" + (rv (apl-transpose (make-array (list 3 3) (list 1 2 3 4 5 6 7 8 9)))) + (list 1 4 7 2 5 8 3 6 9)) + +(apl-test + "transpose 1x4 shape" + (sh (apl-transpose (make-array (list 1 4) (list 1 2 3 4)))) + (list 4 1)) + +(apl-test + "transpose twice identity" + (rv + (apl-transpose + (apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6))))) + (list 1 2 3 4 5 6)) + +(apl-test + "transpose 3d shape" + (sh (apl-transpose (make-array (list 2 3 4) (range 0 24)))) + (list 4 3 2)) + +;; --------------------------------------------------------------------------- +;; 4. Dyadic transpose (perm⍉arr) +;; --------------------------------------------------------------------------- + +(apl-test + "dyadic-transpose identity" + (rv + (apl-transpose-dyadic + (make-array (list 2) (list 1 2)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 2 3 4 5 6)) + +(apl-test + "dyadic-transpose swap 2x3" + (rv + (apl-transpose-dyadic + (make-array (list 2) (list 2 1)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 4 2 5 3 6)) + +(apl-test + "dyadic-transpose swap shape" + (sh + (apl-transpose-dyadic + (make-array (list 2) (list 2 1)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 3 2)) + +(apl-test + "dyadic-transpose 3d shape" + (sh + (apl-transpose-dyadic + (make-array (list 3) (list 2 1 3)) + (make-array (list 2 3 4) (range 0 24)))) + (list 3 2 4)) + +(apl-test + "take 3 from front" + (rv (apl-take (apl-scalar 3) (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 2 3)) + +(apl-test + "take 0" + (rv (apl-take (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5)))) + (list)) + +(apl-test + "take -2 from back" + (rv (apl-take (apl-scalar -2) (make-array (list 5) (list 1 2 3 4 5)))) + (list 4 5)) + +(apl-test + "take over-take pads with 0" + (rv (apl-take (apl-scalar 7) (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 2 3 4 5 0 0)) + +(apl-test + "take matrix 1 row 2 cols shape" + (sh + (apl-take + (make-array (list 2) (list 1 2)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 2)) + +(apl-test + "take matrix 1 row 2 cols ravel" + (rv + (apl-take + (make-array (list 2) (list 1 2)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 2)) + +(apl-test + "take matrix negative row" + (rv + (apl-take + (make-array (list 2) (list -1 3)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 4 5 6)) + +(apl-test + "drop 2 from front" + (rv (apl-drop (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5)))) + (list 3 4 5)) + +(apl-test + "drop -2 from back" + (rv (apl-drop (apl-scalar -2) (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 2 3)) + +(apl-test + "drop all" + (rv (apl-drop (apl-scalar 5) (make-array (list 5) (list 1 2 3 4 5)))) + (list)) + +(apl-test + "drop 0" + (rv (apl-drop (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 2 3 4 5)) + +(apl-test + "drop matrix 1 row shape" + (sh + (apl-drop + (make-array (list 2) (list 1 0)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 3)) + +(apl-test + "drop matrix 1 row ravel" + (rv + (apl-drop + (make-array (list 2) (list 1 0)) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 4 5 6)) + +(apl-test + "reverse vector" + (rv (apl-reverse (make-array (list 5) (list 1 2 3 4 5)))) + (list 5 4 3 2 1)) + +(apl-test + "reverse scalar identity" + (rv (apl-reverse (apl-scalar 42))) + (list 42)) + +(apl-test + "reverse matrix last axis" + (rv (apl-reverse (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 3 2 1 6 5 4)) + +(apl-test + "reverse-first matrix" + (rv (apl-reverse-first (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 4 5 6 1 2 3)) + +(apl-test + "reverse-first vector identity" + (rv (apl-reverse-first (make-array (list 4) (list 1 2 3 4)))) + (list 4 3 2 1)) + +(apl-test + "rotate vector left by 2" + (rv (apl-rotate (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5)))) + (list 3 4 5 1 2)) + +(apl-test + "rotate vector right by 1 (negative)" + (rv (apl-rotate (apl-scalar -1) (make-array (list 5) (list 1 2 3 4 5)))) + (list 5 1 2 3 4)) + +(apl-test + "rotate by 0 is identity" + (rv (apl-rotate (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5)))) + (list 1 2 3 4 5)) + +(apl-test + "rotate matrix last axis" + (rv + (apl-rotate (apl-scalar 1) (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 2 3 1 5 6 4)) + +(apl-test + "rotate-first matrix" + (rv + (apl-rotate-first + (apl-scalar 1) + (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 4 5 6 1 2 3)) + +(apl-test + "cat v,v ravel" + (rv + (apl-catenate + (make-array (list 3) (list 1 2 3)) + (make-array (list 2) (list 4 5)))) + (list 1 2 3 4 5)) + +(apl-test + "cat v,v shape" + (sh + (apl-catenate + (make-array (list 3) (list 1 2 3)) + (make-array (list 2) (list 4 5)))) + (list 5)) + +(apl-test + "cat scalar,v" + (rv (apl-catenate (apl-scalar 99) (make-array (list 3) (list 1 2 3)))) + (list 99 1 2 3)) + +(apl-test + "cat v,scalar" + (rv (apl-catenate (make-array (list 3) (list 1 2 3)) (apl-scalar 99))) + (list 1 2 3 99)) + +(apl-test + "cat matrix last-axis shape" + (sh + (apl-catenate + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 2 2) (list 7 8 9 10)))) + (list 2 5)) + +(apl-test + "cat matrix last-axis ravel" + (rv + (apl-catenate + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 2 2) (list 7 8 9 10)))) + (list 1 2 3 7 8 4 5 6 9 10)) + +(apl-test + "cat-first v,v shape" + (sh + (apl-catenate-first + (make-array (list 3) (list 1 2 3)) + (make-array (list 2) (list 4 5)))) + (list 5)) + +(apl-test + "cat-first matrix shape" + (sh + (apl-catenate-first + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 3 3) (list 11 12 13 14 15 16 17 18 19)))) + (list 5 3)) + +(apl-test + "cat-first matrix ravel" + (rv + (apl-catenate-first + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 3 3) (list 11 12 13 14 15 16 17 18 19)))) + (list 1 2 3 4 5 6 11 12 13 14 15 16 17 18 19)) + +(apl-test + "squad scalar into vector" + (rv + (apl-squad (apl-scalar 2) (make-array (list 5) (list 10 20 30 40 50)))) + (list 20)) + +(apl-test + "squad first element" + (rv (apl-squad (apl-scalar 1) (make-array (list 3) (list 10 20 30)))) + (list 10)) + +(apl-test + "squad last element" + (rv + (apl-squad (apl-scalar 5) (make-array (list 5) (list 10 20 30 40 50)))) + (list 50)) + +(apl-test + "squad fully specified matrix element" + (rv + (apl-squad + (make-array (list 2) (list 2 3)) + (make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12)))) + (list 7)) + +(apl-test + "squad partial row of matrix shape" + (sh + (apl-squad + (apl-scalar 2) + (make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12)))) + (list 4)) + +(apl-test + "squad partial row of matrix ravel" + (rv + (apl-squad + (apl-scalar 2) + (make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12)))) + (list 5 6 7 8)) + +(apl-test + "squad partial 3d slice shape" + (sh (apl-squad (apl-scalar 1) (make-array (list 2 3 4) (range 1 25)))) + (list 3 4)) + +(apl-test + "grade-up basic" + (rv (apl-grade-up (make-array (list 5) (list 3 1 4 1 5)))) + (list 2 4 1 3 5)) + +(apl-test + "grade-up shape" + (sh (apl-grade-up (make-array (list 4) (list 4 1 3 2)))) + (list 4)) + +(apl-test + "grade-up no duplicates" + (rv (apl-grade-up (make-array (list 4) (list 4 1 3 2)))) + (list 2 4 3 1)) + +(apl-test + "grade-up already sorted" + (rv (apl-grade-up (make-array (list 3) (list 1 2 3)))) + (list 1 2 3)) + +(apl-test + "grade-up reverse sorted" + (rv (apl-grade-up (make-array (list 3) (list 3 2 1)))) + (list 3 2 1)) + +(apl-test + "grade-down basic" + (rv (apl-grade-down (make-array (list 5) (list 3 1 4 1 5)))) + (list 5 3 1 2 4)) + +(apl-test + "grade-down no duplicates" + (rv (apl-grade-down (make-array (list 4) (list 4 1 3 2)))) + (list 1 3 4 2)) + +(apl-test + "grade-up single element" + (rv (apl-grade-up (make-array (list 1) (list 42)))) + (list 1)) + +(apl-test + "enclose shape is scalar" + (sh (apl-enclose (make-array (list 3) (list 1 2 3)))) + (list)) + +(apl-test + "enclose ravel length is 1" + (len (rv (apl-enclose (make-array (list 3) (list 1 2 3))))) + 1) + +(apl-test + "enclose inner ravel" + (rv (first (rv (apl-enclose (make-array (list 3) (list 1 2 3)))))) + (list 1 2 3)) + +(apl-test + "disclose of enclose round-trips ravel" + (rv (apl-disclose (apl-enclose (make-array (list 3) (list 10 20 30))))) + (list 10 20 30)) + +(apl-test + "disclose of enclose round-trips shape" + (sh (apl-disclose (apl-enclose (make-array (list 3) (list 10 20 30))))) + (list 3)) + +(apl-test + "disclose scalar ravel" + (rv (apl-disclose (apl-scalar 42))) + (list 42)) + +(apl-test + "disclose vector ravel" + (rv (apl-disclose (make-array (list 3) (list 5 6 7)))) + (list 5)) + +(apl-test + "disclose matrix returns first row" + (rv (apl-disclose (make-array (list 2 3) (list 1 2 3 4 5 6)))) + (list 1 2 3)) + +(apl-test + "member basic" + (rv + (apl-member + (make-array (list 3) (list 1 2 3)) + (make-array (list 2) (list 2 3)))) + (list 0 1 1)) + +(apl-test + "member all absent" + (rv + (apl-member + (make-array (list 3) (list 4 5 6)) + (make-array (list 3) (list 1 2 3)))) + (list 0 0 0)) + +(apl-test + "member scalar" + (rv (apl-member (apl-scalar 5) (make-array (list 3) (list 1 5 9)))) + (list 1)) + +(apl-test + "member shape preserved" + (sh + (apl-member + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 3) (list 1 3 5)))) + (list 2 3)) + +(apl-test + "member matrix ravel" + (rv + (apl-member + (make-array (list 2 3) (list 1 2 3 4 5 6)) + (make-array (list 3) (list 1 3 5)))) + (list 1 0 1 0 1 0)) + +(apl-test + "index-of basic" + (rv + (apl-index-of + (make-array (list 4) (list 10 20 30 40)) + (make-array (list 3) (list 20 40 10)))) + (list 2 4 1)) + +(apl-test + "index-of not-found" + (rv + (apl-index-of + (make-array (list 3) (list 1 2 3)) + (make-array (list 2) (list 5 2)))) + (list 4 2)) + +(apl-test + "index-of scalar right" + (rv + (apl-index-of (make-array (list 3) (list 10 20 30)) (apl-scalar 20))) + (list 2)) + +(apl-test + "without basic" + (rv + (apl-without + (make-array (list 5) (list 1 2 3 4 5)) + (make-array (list 2) (list 2 4)))) + (list 1 3 5)) + +(apl-test + "without shape" + (sh + (apl-without + (make-array (list 5) (list 1 2 3 4 5)) + (make-array (list 2) (list 2 4)))) + (list 3)) + +(apl-test + "without nothing removed" + (rv + (apl-without + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 4 5 6)))) + (list 1 2 3)) + +(apl-test + "without all removed" + (rv + (apl-without + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 1 2 3)))) + (list)) \ No newline at end of file diff --git a/lib/apl/tests/system.sx b/lib/apl/tests/system.sx new file mode 100644 index 00000000..b1057036 --- /dev/null +++ b/lib/apl/tests/system.sx @@ -0,0 +1,48 @@ +; Tests for APL ⎕ system functions. + +(define mkrv (fn (arr) (get arr :ravel))) +(define mksh (fn (arr) (get arr :shape))) + +(apl-test "⎕IO returns 1" (mkrv (apl-quad-io)) (list 1)) + +(apl-test "⎕ML returns 1" (mkrv (apl-quad-ml)) (list 1)) + +(apl-test "⎕FR returns 1248" (mkrv (apl-quad-fr)) (list 1248)) + +(apl-test "⎕TS shape is 7" (mksh (apl-quad-ts)) (list 7)) + +(apl-test "⎕TS year is 1970 default" (first (mkrv (apl-quad-ts))) 1970) + +(apl-test "⎕FMT scalar 42" (apl-quad-fmt (apl-scalar 42)) "42") + +(apl-test "⎕FMT scalar negative" (apl-quad-fmt (apl-scalar -7)) "-7") + +(apl-test + "⎕FMT empty vector" + (apl-quad-fmt (make-array (list 0) (list))) + "") + +(apl-test + "⎕FMT singleton vector" + (apl-quad-fmt (make-array (list 1) (list 42))) + "42") + +(apl-test + "⎕FMT vector" + (apl-quad-fmt (make-array (list 5) (list 1 2 3 4 5))) + "1 2 3 4 5") + +(apl-test + "⎕FMT matrix 2x3" + (apl-quad-fmt (make-array (list 2 3) (list 1 2 3 4 5 6))) + "1 2 3\n4 5 6\n") + +(apl-test + "⎕← (print) returns its arg" + (mkrv (apl-quad-print (apl-scalar 99))) + (list 99)) + +(apl-test + "⎕← preserves shape" + (mksh (apl-quad-print (make-array (list 3) (list 1 2 3)))) + (list 3)) diff --git a/lib/apl/tests/tradfn.sx b/lib/apl/tests/tradfn.sx new file mode 100644 index 00000000..ce4c8dd7 --- /dev/null +++ b/lib/apl/tests/tradfn.sx @@ -0,0 +1,156 @@ +; Tests for apl-call-tradfn (manual structure construction). + +(define mkrv (fn (arr) (get arr :ravel))) +(define mksh (fn (arr) (get arr :shape))) +(define mknum (fn (n) (list :num n))) +(define mknm (fn (s) (list :name s))) +(define mkfg (fn (g) (list :fn-glyph g))) +(define mkmon (fn (g a) (list :monad (mkfg g) a))) +(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r))) +(define mkasg (fn (n e) (list :assign n e))) +(define mkbr (fn (e) (list :branch e))) + +(define mkif (fn (c t e) (list :if c t e))) + +(define mkwhile (fn (c b) (list :while c b))) + +(define mkfor (fn (v i b) (list :for v i b))) + +(define mksel (fn (v cs d) (list :select v cs d))) + +(define mktrap (fn (codes t c) (list :trap codes t c))) + +(define mkthr (fn (code msg) (list :throw code msg))) + +(apl-test + "tradfn R←L+W simple add" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 5) (apl-scalar 7))) + (list 12)) + +(apl-test + "tradfn R←L×W" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 6) (apl-scalar 7))) + (list 42)) + +(apl-test + "tradfn monadic R←-W" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkmon "-" (mknm "W")))) :alpha nil} nil (apl-scalar 9))) + (list -9)) + +(apl-test + "tradfn →0 exits early" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknm "W")) (mkbr (mknum 0)) (mkasg "R" (mknum 999))) :alpha nil} nil (apl-scalar 7))) + (list 7)) + +(apl-test + "tradfn branch to line 3 skips line 2" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkbr (mknum 3)) (mkasg "R" (mknum 999)) (mkasg "R" (mknum 42))) :alpha nil} nil (apl-scalar 0))) + (list 42)) + +(apl-test + "tradfn local var t←W+1; R←t×2" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "t" (mkdyd "+" (mknm "W") (mknum 1))) (mkasg "R" (mkdyd "×" (mknm "t") (mknum 2)))) :alpha nil} nil (apl-scalar 5))) + (list 12)) + +(apl-test + "tradfn vector args" + (mkrv + (apl-call-tradfn + {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"} + (make-array (list 3) (list 1 2 3)) + (make-array (list 3) (list 10 20 30)))) + (list 11 22 33)) + +(apl-test + "tradfn unset result returns nil" + (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkbr (mknum 0))) :alpha nil} nil (apl-scalar 5)) + nil) + +(apl-test + "tradfn run-off end returns result" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "W") (mknum 3)))) :alpha nil} nil (apl-scalar 7))) + (list 21)) + +(apl-test + "tradfn loop sum 1+2+...+5 via branch" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "i" (mknum 1)) (mkasg "R" (mknum 0)) (mkasg "R" (mkdyd "+" (mknm "R") (mknm "i"))) (mkasg "i" (mkdyd "+" (mknm "i") (mknum 1))) (mkbr (mkdyd "×" (mkdyd "≤" (mknm "i") (mknm "W")) (mknum 3)))) :alpha nil} nil (apl-scalar 5))) + (list 15)) + +(apl-test + "tradfn :If true branch" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkasg "R" (mknum 1))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5))) + (list 1)) + +(apl-test + "tradfn :If false branch" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 100)) (list (mkasg "R" (mknum 1))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5))) + (list 0)) + +(apl-test + "tradfn :While sum 1..N" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "i" (mknum 1)) (mkasg "R" (mknum 0)) (mkwhile (mkdyd "≤" (mknm "i") (mknm "W")) (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "i"))) (mkasg "i" (mkdyd "+" (mknm "i") (mknum 1)))))) :alpha nil} nil (apl-scalar 10))) + (list 55)) + +(apl-test + "tradfn :For sum elements" + (mkrv + (apl-call-tradfn + {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 0)) (mkfor "x" (mknm "W") (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "x")))))) :alpha nil} + nil + (make-array (list 4) (list 10 20 30 40)))) + (list 100)) + +(apl-test + "tradfn :For with empty vector" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 99)) (mkfor "x" (mknm "W") (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "x")))))) :alpha nil} nil (make-array (list 0) (list)))) + (list 99)) + +(apl-test + "tradfn :Select dispatch hit" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mksel (mknm "W") (list (list (mknum 1) (mkasg "R" (mknum 100))) (list (mknum 2) (mkasg "R" (mknum 200))) (list (mknum 3) (mkasg "R" (mknum 300)))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 2))) + (list 200)) + +(apl-test + "tradfn :Select default block" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mksel (mknm "W") (list (list (mknum 1) (mkasg "R" (mknum 100))) (list (mknum 2) (mkasg "R" (mknum 200)))) (list (mkasg "R" (mknum -1))))) :alpha nil} nil (apl-scalar 99))) + (list -1)) + +(apl-test + "tradfn nested :If" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkif (mkdyd ">" (mknm "W") (mknum 10)) (list (mkasg "R" (mknum 2))) (list (mkasg "R" (mknum 1))))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5))) + (list 1)) + +(apl-test + "tradfn :If assigns persist outside" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 0)) (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkasg "R" (mknum 42))) (list)) (mkasg "R" (mkdyd "+" (mknm "R") (mknum 1)))) :alpha nil} nil (apl-scalar 5))) + (list 43)) + +(apl-test + "tradfn :For factorial 1..5" + (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 1)) (mkfor "x" (mkmon "⍳" (mknm "W")) (list (mkasg "R" (mkdyd "×" (mknm "R") (mknm "x")))))) :alpha nil} nil (apl-scalar 5))) + (list 120)) + +(apl-test + "tradfn :Trap normal flow (no error)" + (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 0) (list (mkasg "R" (mknum 99))) (list (mkasg "R" (mknum -1))))) :alpha nil} nil nil)) + (list 99)) + +(apl-test + "tradfn :Trap catches matching code" + (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 5) (list (mkthr 5 "boom")) (list (mkasg "R" (mknum 42))))) :alpha nil} nil nil)) + (list 42)) + +(apl-test + "tradfn :Trap catch-all (code 0)" + (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 0) (list (mkthr 99 "any")) (list (mkasg "R" (mknum 1))))) :alpha nil} nil nil)) + (list 1)) + +(apl-test + "tradfn :Trap catches one of many codes" + (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 1 2 3) (list (mkthr 2 "two")) (list (mkasg "R" (mknum 22))))) :alpha nil} nil nil)) + (list 22)) + +(apl-test + "tradfn :Trap continues to next stmt after catch" + (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 7) (list (mkthr 7 "c")) (list (mkasg "R" (mknum 10)))) (mkasg "R" (mkdyd "+" (mknm "R") (mknum 5)))) :alpha nil} nil nil)) + (list 15)) diff --git a/lib/apl/tests/valence.sx b/lib/apl/tests/valence.sx new file mode 100644 index 00000000..3404db20 --- /dev/null +++ b/lib/apl/tests/valence.sx @@ -0,0 +1,81 @@ +; Tests for valence detection (apl-dfn-valence, apl-tradfn-valence) +; and unified dispatch (apl-call). + +(define mkrv (fn (arr) (get arr :ravel))) +(define mknum (fn (n) (list :num n))) +(define mknm (fn (s) (list :name s))) +(define mkfg (fn (g) (list :fn-glyph g))) +(define mkmon (fn (g a) (list :monad (mkfg g) a))) +(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r))) +(define mkasg (fn (n e) (list :assign n e))) +(define mkdfn (fn (stmts) (cons :dfn stmts))) + +(apl-test + "dfn-valence niladic body=42" + (apl-dfn-valence (mkdfn (list (mknum 42)))) + :niladic) + +(apl-test + "dfn-valence monadic body=⍵+1" + (apl-dfn-valence (mkdfn (list (mkdyd "+" (mknm "⍵") (mknum 1))))) + :monadic) + +(apl-test + "dfn-valence dyadic body=⍺+⍵" + (apl-dfn-valence (mkdfn (list (mkdyd "+" (mknm "⍺") (mknm "⍵"))))) + :dyadic) + +(apl-test + "dfn-valence dyadic mentions ⍺ via local" + (apl-dfn-valence (mkdfn (list (mkasg "x" (mknm "⍺")) (mknm "x")))) + :dyadic) + +(apl-test + "dfn-valence dyadic deep nest" + (apl-dfn-valence + (mkdfn (list (mkmon "-" (mkdyd "×" (mknm "⍺") (mknm "⍵")))))) + :dyadic) + +(apl-test "tradfn-valence niladic" (apl-tradfn-valence {:result "R" :omega nil :stmts (list) :alpha nil}) :niladic) + +(apl-test "tradfn-valence monadic" (apl-tradfn-valence {:result "R" :omega "W" :stmts (list) :alpha nil}) :monadic) + +(apl-test "tradfn-valence dyadic" (apl-tradfn-valence {:result "R" :omega "W" :stmts (list) :alpha "L"}) :dyadic) + +(apl-test + "apl-call dfn niladic" + (mkrv (apl-call (mkdfn (list (mknum 42))) nil nil)) + (list 42)) + +(apl-test + "apl-call dfn monadic" + (mkrv + (apl-call + (mkdfn (list (mkdyd "+" (mknm "⍵") (mknum 1)))) + nil + (apl-scalar 5))) + (list 6)) + +(apl-test + "apl-call dfn dyadic" + (mkrv + (apl-call + (mkdfn (list (mkdyd "+" (mknm "⍺") (mknm "⍵")))) + (apl-scalar 3) + (apl-scalar 4))) + (list 7)) + +(apl-test + "apl-call tradfn dyadic" + (mkrv (apl-call {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 6) (apl-scalar 7))) + (list 42)) + +(apl-test + "apl-call tradfn monadic" + (mkrv (apl-call {:result "R" :omega "W" :stmts (list (mkasg "R" (mkmon "-" (mknm "W")))) :alpha nil} nil (apl-scalar 9))) + (list -9)) + +(apl-test + "apl-call tradfn niladic returns nil result" + (apl-call {:result "R" :omega nil :stmts (list) :alpha nil} nil nil) + nil) diff --git a/lib/apl/tokenizer.sx b/lib/apl/tokenizer.sx new file mode 100644 index 00000000..76dcf5be --- /dev/null +++ b/lib/apl/tokenizer.sx @@ -0,0 +1,180 @@ +(define apl-glyph-set + (list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠" + "≢" "≡" "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆" + "∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕" + "⍺" "⍵" "∇" "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯")) + +(define apl-glyph? + (fn (ch) + (some (fn (g) (= g ch)) apl-glyph-set))) + +(define apl-digit? + (fn (ch) + (and (string? ch) (>= ch "0") (<= ch "9")))) + +(define apl-alpha? + (fn (ch) + (and (string? ch) + (or (and (>= ch "a") (<= ch "z")) + (and (>= ch "A") (<= ch "Z")) + (= ch "_"))))) + +(define apl-tokenize + (fn (source) + (let ((pos 0) + (src-len (len source)) + (tokens (list))) + + (define tok-push! + (fn (type value) + (append! tokens {:type type :value value}))) + + (define cur-sw? + (fn (ch) + (and (< pos src-len) (starts-with? (slice source pos) ch)))) + + (define cur-byte + (fn () + (if (< pos src-len) (nth source pos) nil))) + + (define advance! + (fn () + (set! pos (+ pos 1)))) + + (define consume! + (fn (ch) + (set! pos (+ pos (len ch))))) + + (define find-glyph + (fn () + (let ((rem (slice source pos))) + (let ((matches (filter (fn (g) (starts-with? rem g)) apl-glyph-set))) + (if (> (len matches) 0) (first matches) nil))))) + + (define read-digits! + (fn (acc) + (if (and (< pos src-len) (apl-digit? (cur-byte))) + (let ((ch (cur-byte))) + (begin + (advance!) + (read-digits! (str acc ch)))) + acc))) + + (define read-ident-cont! + (fn () + (when (and (< pos src-len) + (let ((ch (cur-byte))) + (or (apl-alpha? ch) (apl-digit? ch)))) + (begin + (advance!) + (read-ident-cont!))))) + + (define read-string! + (fn (acc) + (cond + ((>= pos src-len) acc) + ((cur-sw? "'") + (if (and (< (+ pos 1) src-len) (cur-sw? "'")) + (begin + (advance!) + (advance!) + (read-string! (str acc "'"))) + (begin (advance!) acc))) + (true + (let ((ch (cur-byte))) + (begin + (advance!) + (read-string! (str acc ch)))))))) + + (define skip-line! + (fn () + (when (and (< pos src-len) (not (cur-sw? "\n"))) + (begin + (advance!) + (skip-line!))))) + + (define scan! + (fn () + (when (< pos src-len) + (let ((ch (cur-byte))) + (cond + ((or (= ch " ") (= ch "\t") (= ch "\r")) + (begin (advance!) (scan!))) + ((= ch "\n") + (begin (advance!) (tok-push! :newline nil) (scan!))) + ((cur-sw? "⍝") + (begin (skip-line!) (scan!))) + ((cur-sw? "⋄") + (begin (consume! "⋄") (tok-push! :diamond nil) (scan!))) + ((= ch "(") + (begin (advance!) (tok-push! :lparen nil) (scan!))) + ((= ch ")") + (begin (advance!) (tok-push! :rparen nil) (scan!))) + ((= ch "[") + (begin (advance!) (tok-push! :lbracket nil) (scan!))) + ((= ch "]") + (begin (advance!) (tok-push! :rbracket nil) (scan!))) + ((= ch "{") + (begin (advance!) (tok-push! :lbrace nil) (scan!))) + ((= ch "}") + (begin (advance!) (tok-push! :rbrace nil) (scan!))) + ((= ch ";") + (begin (advance!) (tok-push! :semi nil) (scan!))) + ((cur-sw? "←") + (begin (consume! "←") (tok-push! :assign nil) (scan!))) + ((= ch ":") + (let ((start pos)) + (begin + (advance!) + (if (and (< pos src-len) (apl-alpha? (cur-byte))) + (begin + (read-ident-cont!) + (tok-push! :keyword (slice source start pos))) + (tok-push! :colon nil)) + (scan!)))) + ((and (cur-sw? "¯") + (< (+ pos (len "¯")) src-len) + (apl-digit? (nth source (+ pos (len "¯"))))) + (begin + (consume! "¯") + (let ((digits (read-digits! ""))) + (if (and (< pos src-len) (= (cur-byte) ".") + (< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1)))) + (begin (advance!) + (let ((frac (read-digits! ""))) + (tok-push! :num (- 0 (string->number (str digits "." frac)))))) + (tok-push! :num (- 0 (parse-int digits 0))))) + (scan!))) + ((apl-digit? ch) + (begin + (let ((digits (read-digits! ""))) + (if (and (< pos src-len) (= (cur-byte) ".") + (< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1)))) + (begin (advance!) + (let ((frac (read-digits! ""))) + (tok-push! :num (string->number (str digits "." frac))))) + (tok-push! :num (parse-int digits 0)))) + (scan!))) + ((= ch "'") + (begin + (advance!) + (let ((s (read-string! ""))) + (tok-push! :str s)) + (scan!))) + ((or (apl-alpha? ch) (cur-sw? "⎕")) + (let ((start pos)) + (begin + (if (cur-sw? "⎕") (consume! "⎕") (advance!)) + (if (and (< pos src-len) (cur-sw? "←")) + (consume! "←") + (read-ident-cont!)) + (tok-push! :name (slice source start pos)) + (scan!)))) + (true + (let ((g (find-glyph))) + (if g + (begin (consume! g) (tok-push! :glyph g) (scan!)) + (begin (advance!) (scan!)))))))))) + + (scan!) + tokens))) diff --git a/lib/apl/transpile.sx b/lib/apl/transpile.sx new file mode 100644 index 00000000..f0771138 --- /dev/null +++ b/lib/apl/transpile.sx @@ -0,0 +1,540 @@ +; APL transpile / AST evaluator +; +; Walks parsed AST nodes and evaluates against the runtime. +; Entry points: +; apl-eval-ast : node × env → value +; apl-eval-stmts : stmt-list × env → value (handles guards, locals, ⍺← default) +; apl-call-dfn : dfn-ast × ⍺ × ⍵ → value (dyadic) +; apl-call-dfn-m : dfn-ast × ⍵ → value (monadic) +; +; Env is a dict; ⍺ stored under "alpha", ⍵ under "omega", +; the dfn-ast itself under "nabla" (for ∇ recursion), +; user names under their literal name. + +(define + apl-monadic-fn + (fn + (g) + (cond + ((= g "+") apl-plus-m) + ((= g "-") apl-neg-m) + ((= g "×") apl-signum) + ((= g "÷") apl-recip) + ((= g "⌈") apl-ceil) + ((= g "⌊") apl-floor) + ((= g "⍳") apl-iota) + ((= g "|") apl-abs) + ((= g "*") apl-exp) + ((= g "⍟") apl-ln) + ((= g "!") apl-fact) + ((= g "○") apl-pi-times) + ((= g "~") apl-not) + ((= g "≢") apl-tally) + ((= g "⍴") apl-shape) + ((= g "≡") apl-depth) + ((= g "⊂") apl-enclose) + ((= g "⊃") apl-disclose) + ((= g ",") apl-ravel) + ((= g "⌽") apl-reverse) + ((= g "⊖") apl-reverse-first) + ((= g "⍋") apl-grade-up) + ((= g "⍒") apl-grade-down) + ((= g "⎕FMT") apl-quad-fmt) + ((= g "⎕←") apl-quad-print) + (else (error "no monadic fn for glyph"))))) + +(define + apl-dyadic-fn + (fn + (g) + (cond + ((= g "+") apl-add) + ((= g "-") apl-sub) + ((= g "×") apl-mul) + ((= g "÷") apl-div) + ((= g "⌈") apl-max) + ((= g "⌊") apl-min) + ((= g "*") apl-pow) + ((= g "⍟") apl-log) + ((= g "|") apl-mod) + ((= g "!") apl-binomial) + ((= g "○") apl-trig) + ((= g "<") apl-lt) + ((= g "≤") apl-le) + ((= g "=") apl-eq) + ((= g "≥") apl-ge) + ((= g ">") apl-gt) + ((= g "≠") apl-ne) + ((= g "∧") apl-and) + ((= g "∨") apl-or) + ((= g "⍱") apl-nor) + ((= g "⍲") apl-nand) + ((= g ",") apl-catenate) + ((= g "⍪") apl-catenate-first) + ((= g "⍴") apl-reshape) + ((= g "↑") apl-take) + ((= g "↓") apl-drop) + ((= g "⌷") apl-squad) + ((= g "⌽") apl-rotate) + ((= g "⊖") apl-rotate-first) + ((= g "∊") apl-member) + ((= g "⍳") apl-index-of) + ((= g "~") apl-without) + (else (error "no dyadic fn for glyph"))))) + +(define + apl-truthy? + (fn + (v) + (let + ((rv (get v :ravel))) + (if (and (= (len rv) 1) (= (first rv) 0)) false true)))) + +(define + apl-eval-ast + (fn + (node env) + (let + ((tag (first node))) + (cond + ((= tag :num) (apl-scalar (nth node 1))) + ((= tag :str) + (let + ((s (nth node 1))) + (if + (= (len s) 1) + (apl-scalar s) + (make-array + (list (len s)) + (map (fn (i) (slice s i (+ i 1))) (range 0 (len s))))))) + ((= tag :vec) + (let + ((items (rest node))) + (let + ((vals (map (fn (n) (apl-eval-ast n env)) items))) + (make-array + (list (len vals)) + (map (fn (v) (first (get v :ravel))) vals))))) + ((= tag :name) + (let + ((nm (nth node 1))) + (cond + ((= nm "⍺") (get env "alpha")) + ((= nm "⍵") (get env "omega")) + ((= nm "⎕IO") (apl-quad-io)) + ((= nm "⎕ML") (apl-quad-ml)) + ((= nm "⎕FR") (apl-quad-fr)) + ((= nm "⎕TS") (apl-quad-ts)) + (else (get env nm))))) + ((= tag :monad) + (let + ((fn-node (nth node 1)) (arg (nth node 2))) + (if + (and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇")) + (apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env)) + ((apl-resolve-monadic fn-node env) (apl-eval-ast arg env))))) + ((= tag :dyad) + (let + ((fn-node (nth node 1)) + (lhs (nth node 2)) + (rhs (nth node 3))) + (if + (and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇")) + (apl-call-dfn + (get env "nabla") + (apl-eval-ast lhs env) + (apl-eval-ast rhs env)) + ((apl-resolve-dyadic fn-node env) + (apl-eval-ast lhs env) + (apl-eval-ast rhs env))))) + ((= tag :program) (apl-eval-stmts (rest node) env)) + ((= tag :dfn) node) + ((= tag :bracket) + (let + ((arr-expr (nth node 1)) (axis-exprs (rest (rest node)))) + (let + ((arr (apl-eval-ast arr-expr env)) + (axes + (map + (fn (a) (if (= a :all) nil (apl-eval-ast a env))) + axis-exprs))) + (apl-bracket-multi axes arr)))) + (else (error (list "apl-eval-ast: unknown node tag" tag node))))))) + +(define + apl-eval-stmts + (fn + (stmts env) + (if + (= (len stmts) 0) + nil + (let + ((stmt (first stmts)) (more (rest stmts))) + (let + ((tag (first stmt))) + (cond + ((= tag :guard) + (let + ((cond-val (apl-eval-ast (nth stmt 1) env))) + (if + (apl-truthy? cond-val) + (apl-eval-ast (nth stmt 2) env) + (apl-eval-stmts more env)))) + ((and (= tag :assign) (= (nth stmt 1) "⍺")) + (if + (get env "alpha") + (apl-eval-stmts more env) + (let + ((v (apl-eval-ast (nth stmt 2) env))) + (apl-eval-stmts more (assoc env "alpha" v))))) + ((= tag :assign) + (let + ((v (apl-eval-ast (nth stmt 2) env))) + (apl-eval-stmts more (assoc env (nth stmt 1) v)))) + ((= (len more) 0) (apl-eval-ast stmt env)) + (else (begin (apl-eval-ast stmt env) (apl-eval-stmts more env))))))))) + +(define + apl-call-dfn + (fn + (dfn-ast alpha omega) + (let + ((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha alpha})) + (apl-eval-stmts stmts env)))) + +(define + apl-call-dfn-m + (fn + (dfn-ast omega) + (let + ((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha nil})) + (apl-eval-stmts stmts env)))) + +(define + apl-tradfn-eval-block + (fn + (stmts env) + (if + (= (len stmts) 0) + env + (let + ((stmt (first stmts))) + (apl-tradfn-eval-block (rest stmts) (apl-tradfn-eval-stmt stmt env)))))) + +(define + apl-tradfn-eval-while + (fn + (cond-expr body env) + (let + ((cond-val (apl-eval-ast cond-expr env))) + (if + (apl-truthy? cond-val) + (apl-tradfn-eval-while + cond-expr + body + (apl-tradfn-eval-block body env)) + env)))) + +(define + apl-tradfn-eval-for + (fn + (var-name items body env) + (if + (= (len items) 0) + env + (let + ((env-with-var (assoc env var-name (apl-scalar (first items))))) + (apl-tradfn-eval-for + var-name + (rest items) + body + (apl-tradfn-eval-block body env-with-var)))))) + +(define + apl-tradfn-eval-select + (fn + (val cases default-block env) + (if + (= (len cases) 0) + (apl-tradfn-eval-block default-block env) + (let + ((c (first cases))) + (let + ((case-val (apl-eval-ast (first c) env))) + (if + (= (first (get val :ravel)) (first (get case-val :ravel))) + (apl-tradfn-eval-block (rest c) env) + (apl-tradfn-eval-select val (rest cases) default-block env))))))) + +(define + apl-tradfn-eval-stmt + (fn + (stmt env) + (let + ((tag (first stmt))) + (cond + ((= tag :assign) + (assoc env (nth stmt 1) (apl-eval-ast (nth stmt 2) env))) + ((= tag :if) + (let + ((cond-val (apl-eval-ast (nth stmt 1) env))) + (if + (apl-truthy? cond-val) + (apl-tradfn-eval-block (nth stmt 2) env) + (apl-tradfn-eval-block (nth stmt 3) env)))) + ((= tag :while) + (apl-tradfn-eval-while (nth stmt 1) (nth stmt 2) env)) + ((= tag :for) + (let + ((iter-val (apl-eval-ast (nth stmt 2) env))) + (apl-tradfn-eval-for + (nth stmt 1) + (get iter-val :ravel) + (nth stmt 3) + env))) + ((= tag :select) + (let + ((val (apl-eval-ast (nth stmt 1) env))) + (apl-tradfn-eval-select val (nth stmt 2) (nth stmt 3) env))) + ((= tag :trap) + (let + ((codes (nth stmt 1)) + (try-block (nth stmt 2)) + (catch-block (nth stmt 3))) + (guard + (e + ((apl-trap-matches? codes e) + (apl-tradfn-eval-block catch-block env))) + (apl-tradfn-eval-block try-block env)))) + ((= tag :throw) (apl-throw (nth stmt 1) (nth stmt 2))) + (else (begin (apl-eval-ast stmt env) env)))))) + +(define + apl-tradfn-loop + (fn + (stmts line env result-name) + (cond + ((= line 0) (get env result-name)) + ((> line (len stmts)) (get env result-name)) + (else + (let + ((stmt (nth stmts (- line 1)))) + (let + ((tag (first stmt))) + (cond + ((= tag :branch) + (let + ((target (apl-eval-ast (nth stmt 1) env))) + (let + ((target-num (first (get target :ravel)))) + (apl-tradfn-loop stmts target-num env result-name)))) + (else + (apl-tradfn-loop + stmts + (+ line 1) + (apl-tradfn-eval-stmt stmt env) + result-name))))))))) + +(define + apl-call-tradfn + (fn + (tradfn alpha omega) + (let + ((stmts (get tradfn :stmts)) + (result-name (get tradfn :result)) + (alpha-name (get tradfn :alpha)) + (omega-name (get tradfn :omega))) + (let + ((env-a (if alpha-name (assoc {} alpha-name alpha) {}))) + (let + ((env-ao (if omega-name (assoc env-a omega-name omega) env-a))) + (apl-tradfn-loop stmts 1 env-ao result-name)))))) + +(define + apl-ast-mentions-list? + (fn + (lst target) + (if + (= (len lst) 0) + false + (if + (apl-ast-mentions? (first lst) target) + true + (apl-ast-mentions-list? (rest lst) target))))) + +(define + apl-ast-mentions? + (fn + (node target) + (cond + ((not (list? node)) false) + ((= (len node) 0) false) + ((and (= (first node) :name) (= (nth node 1) target)) true) + (else (apl-ast-mentions-list? (rest node) target))))) + +(define + apl-dfn-valence + (fn + (dfn-ast) + (let + ((body (rest dfn-ast))) + (cond + ((apl-ast-mentions-list? body "⍺") :dyadic) + ((apl-ast-mentions-list? body "⍵") :monadic) + (else :niladic))))) + +(define + apl-tradfn-valence + (fn + (tradfn) + (cond + ((get tradfn :alpha) :dyadic) + ((get tradfn :omega) :monadic) + (else :niladic)))) + +(define + apl-call + (fn + (f alpha omega) + (cond + ((and (list? f) (> (len f) 0) (= (first f) :dfn)) + (if alpha (apl-call-dfn f alpha omega) (apl-call-dfn-m f omega))) + ((dict? f) (apl-call-tradfn f alpha omega)) + (else (error "apl-call: not a function"))))) + +(define + apl-resolve-monadic + (fn + (fn-node env) + (let + ((tag (first fn-node))) + (cond + ((= tag :fn-glyph) (apl-monadic-fn (nth fn-node 1))) + ((= tag :derived-fn) + (let + ((op (nth fn-node 1)) (inner (nth fn-node 2))) + (cond + ((= op "/") + (let + ((f (apl-resolve-dyadic inner env))) + (fn (arr) (apl-reduce f arr)))) + ((= op "⌿") + (let + ((f (apl-resolve-dyadic inner env))) + (fn (arr) (apl-reduce-first f arr)))) + ((= op "\\") + (let + ((f (apl-resolve-dyadic inner env))) + (fn (arr) (apl-scan f arr)))) + ((= op "⍀") + (let + ((f (apl-resolve-dyadic inner env))) + (fn (arr) (apl-scan-first f arr)))) + ((= op "¨") + (let + ((f (apl-resolve-monadic inner env))) + (fn (arr) (apl-each f arr)))) + ((= op "⍨") + (let + ((f (apl-resolve-dyadic inner env))) + (fn (arr) (apl-commute f arr)))) + (else (error "apl-resolve-monadic: unsupported op"))))) + ((= tag :fn-name) + (let + ((nm (nth fn-node 1))) + (let + ((bound (get env nm))) + (if + (and + (list? bound) + (> (len bound) 0) + (= (first bound) :dfn)) + (fn (arg) (apl-call-dfn-m bound arg)) + (error "apl-resolve-monadic: name not bound to dfn"))))) + ((= tag :train) + (let + ((fns (rest fn-node))) + (let + ((n (len fns))) + (cond + ((= n 2) + (let + ((g (apl-resolve-monadic (nth fns 0) env)) + (h (apl-resolve-monadic (nth fns 1) env))) + (fn (arg) (g (h arg))))) + ((= n 3) + (let + ((f (apl-resolve-monadic (nth fns 0) env)) + (g (apl-resolve-dyadic (nth fns 1) env)) + (h (apl-resolve-monadic (nth fns 2) env))) + (fn (arg) (g (f arg) (h arg))))) + (else (error "monadic train arity not 2 or 3")))))) + (else (error "apl-resolve-monadic: unknown fn-node tag")))))) + +(define + apl-resolve-dyadic + (fn + (fn-node env) + (let + ((tag (first fn-node))) + (cond + ((= tag :fn-glyph) (apl-dyadic-fn (nth fn-node 1))) + ((= tag :derived-fn) + (let + ((op (nth fn-node 1)) (inner (nth fn-node 2))) + (cond + ((= op "¨") + (let + ((f (apl-resolve-dyadic inner env))) + (fn (a b) (apl-each-dyadic f a b)))) + ((= op "⍨") + (let + ((f (apl-resolve-dyadic inner env))) + (fn (a b) (apl-commute-dyadic f a b)))) + (else (error "apl-resolve-dyadic: unsupported op"))))) + ((= tag :fn-name) + (let + ((nm (nth fn-node 1))) + (let + ((bound (get env nm))) + (if + (and + (list? bound) + (> (len bound) 0) + (= (first bound) :dfn)) + (fn (a b) (apl-call-dfn bound a b)) + (error "apl-resolve-dyadic: name not bound to dfn"))))) + ((= tag :outer) + (let + ((inner (nth fn-node 2))) + (let + ((f (apl-resolve-dyadic inner env))) + (fn (a b) (apl-outer f a b))))) + ((= tag :derived-fn2) + (let + ((f-node (nth fn-node 2)) (g-node (nth fn-node 3))) + (let + ((f (apl-resolve-dyadic f-node env)) + (g (apl-resolve-dyadic g-node env))) + (fn (a b) (apl-inner f g a b))))) + ((= tag :train) + (let + ((fns (rest fn-node))) + (let + ((n (len fns))) + (cond + ((= n 2) + (let + ((g (apl-resolve-monadic (nth fns 0) env)) + (h (apl-resolve-dyadic (nth fns 1) env))) + (fn (a b) (g (h a b))))) + ((= n 3) + (let + ((f (apl-resolve-dyadic (nth fns 0) env)) + (g (apl-resolve-dyadic (nth fns 1) env)) + (h (apl-resolve-dyadic (nth fns 2) env))) + (fn (a b) (g (f a b) (h a b))))) + (else (error "dyadic train arity not 2 or 3")))))) + (else (error "apl-resolve-dyadic: unknown fn-node tag")))))) + +(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {}))) 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..fac437a8 --- /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(load "lib/guest/prefix.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..a43d2905 --- /dev/null +++ b/lib/common-lisp/runtime.sx @@ -0,0 +1,760 @@ +;; 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")))) + +(prefix-rename "cl-" + '( + (integerp? integer?) + (floatp? float?) + (rationalp? rational?) + )) + +(define (cl-realp? x) (or (integer? x) (float? x) (rational? x))) + +(prefix-rename "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")))) + +(prefix-rename "cl-" + '( + (vectorp? vector?) + (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 +;; --------------------------------------------------------------------------- + +(prefix-rename "cl-" + '( + (mod modulo) + (rem remainder) + gcd + lcm + expt + floor + (ceiling ceil) + truncate + 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))) +(prefix-rename "cl-" + '( + 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 +;; --------------------------------------------------------------------------- + +(prefix-rename "cl-" + '( + char->integer + integer->char + char-upcase + char-downcase + (char-code char->integer) + (code-char integer->char) + )) + +(prefix-rename "cl-" + '( + char=? + char? + char<=? + char>=? + 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))) + +(prefix-rename "cl-" + '( + write-to-string + (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) +(prefix-rename "cl-" + '( + (make-string-output-stream open-output-string) + (get-output-stream-string get-output-string) + )) + +;; String stream (input) +(prefix-rename "cl-" + '( + (make-string-input-stream open-input-string) + )) + +;; --------------------------------------------------------------------------- +;; 5. Gensym +;; --------------------------------------------------------------------------- + +(prefix-rename "cl-" + '( + gensym + (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) +;; --------------------------------------------------------------------------- + +(prefix-rename "cl-" + '( + make-set + set? + (set-add set-add!) + (set-memberp set-member?) + (set-remove set-remove!) + set-union + (set-intersect set-intersection) + set-difference + list->set + 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..d324cb4e --- /dev/null +++ b/lib/common-lisp/scoreboard.json @@ -0,0 +1,19 @@ +{ + "generated": "2026-05-06T22:55:42Z", + "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..55c4febe --- /dev/null +++ b/lib/common-lisp/scoreboard.md @@ -0,0 +1,20 @@ +# Common Lisp on SX — Scoreboard + +_Generated: 2026-05-06 22:55 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/compiler.sx b/lib/compiler.sx index 02912708..21510270 100644 --- a/lib/compiler.sx +++ b/lib/compiler.sx @@ -1008,11 +1008,27 @@ (let ((name (symbol-name head)) (argc (len args)) - (name-idx (pool-add (get em "pool") name))) + (specialized-op (cond + (and (= argc 2) (= name "+")) 160 + (and (= argc 2) (= name "-")) 161 + (and (= argc 2) (= name "*")) 162 + (and (= argc 2) (= name "/")) 163 + (and (= argc 2) (= name "=")) 164 + (and (= argc 2) (= name "<")) 165 + (and (= argc 2) (= name ">")) 166 + (and (= argc 2) (= name "cons")) 172 + (and (= argc 1) (= name "not")) 167 + (and (= argc 1) (= name "len")) 168 + (and (= argc 1) (= name "first")) 169 + (and (= argc 1) (= name "rest")) 170 + :else nil))) (for-each (fn (a) (compile-expr em a scope false)) args) - (emit-op em 52) - (emit-u16 em name-idx) - (emit-byte em argc)) + (if specialized-op + (emit-op em specialized-op) + (let ((name-idx (pool-add (get em "pool") name))) + (emit-op em 52) + (emit-u16 em name-idx) + (emit-byte em argc)))) (do (compile-expr em head scope false) (for-each (fn (a) (compile-expr em a scope false)) args) 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..3d5a2b0e --- /dev/null +++ b/lib/erlang/scoreboard.json @@ -0,0 +1,16 @@ +{ + "language": "erlang", + "total_pass": 0, + "total": 0, + "suites": [ + {"name":"tokenize","pass":0,"total":0,"status":"ok"}, + {"name":"parse","pass":0,"total":0,"status":"ok"}, + {"name":"eval","pass":0,"total":0,"status":"ok"}, + {"name":"runtime","pass":0,"total":0,"status":"ok"}, + {"name":"ring","pass":0,"total":0,"status":"ok"}, + {"name":"ping-pong","pass":0,"total":0,"status":"ok"}, + {"name":"bank","pass":0,"total":0,"status":"ok"}, + {"name":"echo","pass":0,"total":0,"status":"ok"}, + {"name":"fib","pass":0,"total":0,"status":"ok"} + ] +} diff --git a/lib/erlang/scoreboard.md b/lib/erlang/scoreboard.md new file mode 100644 index 00000000..f5a775c5 --- /dev/null +++ b/lib/erlang/scoreboard.md @@ -0,0 +1,18 @@ +# Erlang-on-SX Scoreboard + +**Total: 0 / 0 tests passing** + +| | Suite | Pass | Total | +|---|---|---|---| +| ✅ | tokenize | 0 | 0 | +| ✅ | parse | 0 | 0 | +| ✅ | eval | 0 | 0 | +| ✅ | runtime | 0 | 0 | +| ✅ | ring | 0 | 0 | +| ✅ | ping-pong | 0 | 0 | +| ✅ | bank | 0 | 0 | +| ✅ | echo | 0 | 0 | +| ✅ | fib | 0 | 0 | + + +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/fiber.sx b/lib/fiber.sx new file mode 100644 index 00000000..68390720 --- /dev/null +++ b/lib/fiber.sx @@ -0,0 +1,44 @@ +; lib/fiber.sx — pure SX fiber library using call/cc +; +; A fiber is a cooperative coroutine with true suspension (no eager +; pre-execution). Each fiber is a dict {:resume fn :done? fn}. +; +; make-fiber body → fiber dict +; body = (fn (yield init-val) ...) — body receives yield + first resume val +; yield = (fn (val) ...) — suspends fiber, returns val to resumer +; +; fiber-resume f v → next yielded value, or nil when body returns +; fiber-done? f → true after body has returned + +(define make-fiber + (fn (body) + (let + ((resume-k nil) + (caller-k nil) + (done false)) + (let + ((yield + (fn (val) + (call/cc + (fn (k) + (set! resume-k k) + (caller-k val)))))) + {:resume + (fn (val) + (if + done + nil + (call/cc + (fn (k) + (set! caller-k k) + (if + (nil? resume-k) + (begin + (body yield val) + (set! done true) + (k nil)) + (resume-k val)))))) + :done? (fn () done)})))) + +(define fiber-resume (fn (f v) ((get f :resume) v))) +(define fiber-done? (fn (f) ((get f :done?)))) 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/guest/ast.sx b/lib/guest/ast.sx new file mode 100644 index 00000000..3f72f9bf --- /dev/null +++ b/lib/guest/ast.sx @@ -0,0 +1,92 @@ +;; lib/guest/ast.sx — canonical AST node shapes. +;; +;; A guest's parser may emit its own AST in whatever shape is convenient +;; for that language's evaluator/transpiler. This file gives a SHARED +;; canonical shape that cross-language tools (formatters, highlighters, +;; debuggers) can target without per-language adapters. +;; +;; Each canonical node is a tagged list: (KIND ...payload). +;; +;; Constructors (return a canonical node): +;; +;; (ast-literal VALUE) — number / string / bool / nil +;; (ast-var NAME) — identifier reference +;; (ast-app FN ARGS) — function application +;; (ast-lambda PARAMS BODY) — anonymous function +;; (ast-let BINDINGS BODY) — local bindings +;; (ast-letrec BINDINGS BODY) — recursive local bindings +;; (ast-if TEST THEN ELSE) — conditional +;; (ast-match-clause PATTERN BODY) — one match arm +;; (ast-module NAME BODY) — module declaration +;; (ast-import NAME) — import directive +;; +;; Predicates: (ast-literal? X), (ast-var? X), … +;; Generic: (ast? X) — any canonical node +;; (ast-kind X) — :literal / :var / :app / … +;; +;; Accessors (one per payload field): +;; (ast-literal-value N) +;; (ast-var-name N) +;; (ast-app-fn N) (ast-app-args N) +;; (ast-lambda-params N) (ast-lambda-body N) +;; (ast-let-bindings N) (ast-let-body N) +;; (ast-letrec-bindings N) (ast-letrec-body N) +;; (ast-if-test N) (ast-if-then N) (ast-if-else N) +;; (ast-match-clause-pattern N) +;; (ast-match-clause-body N) +;; (ast-module-name N) (ast-module-body N) +;; (ast-import-name N) + +(define ast-literal (fn (v) (list :literal v))) +(define ast-var (fn (n) (list :var n))) +(define ast-app (fn (f args) (list :app f args))) +(define ast-lambda (fn (ps body) (list :lambda ps body))) +(define ast-let (fn (bs body) (list :let bs body))) +(define ast-letrec (fn (bs body) (list :letrec bs body))) +(define ast-if (fn (t th el) (list :if t th el))) +(define ast-match-clause (fn (p body) (list :match-clause p body))) +(define ast-module (fn (n body) (list :module n body))) +(define ast-import (fn (n) (list :import n))) + +(define ast-kind (fn (x) (if (and (list? x) (not (empty? x))) (first x) nil))) + +(define + ast? + (fn (x) + (and (list? x) + (not (empty? x)) + (let ((k (first x))) + (or (= k :literal) (= k :var) (= k :app) + (= k :lambda) (= k :let) (= k :letrec) + (= k :if) (= k :match-clause) + (= k :module) (= k :import)))))) + +(define ast-literal? (fn (x) (and (ast? x) (= (first x) :literal)))) +(define ast-var? (fn (x) (and (ast? x) (= (first x) :var)))) +(define ast-app? (fn (x) (and (ast? x) (= (first x) :app)))) +(define ast-lambda? (fn (x) (and (ast? x) (= (first x) :lambda)))) +(define ast-let? (fn (x) (and (ast? x) (= (first x) :let)))) +(define ast-letrec? (fn (x) (and (ast? x) (= (first x) :letrec)))) +(define ast-if? (fn (x) (and (ast? x) (= (first x) :if)))) +(define ast-match-clause? (fn (x) (and (ast? x) (= (first x) :match-clause)))) +(define ast-module? (fn (x) (and (ast? x) (= (first x) :module)))) +(define ast-import? (fn (x) (and (ast? x) (= (first x) :import)))) + +(define ast-literal-value (fn (n) (nth n 1))) +(define ast-var-name (fn (n) (nth n 1))) +(define ast-app-fn (fn (n) (nth n 1))) +(define ast-app-args (fn (n) (nth n 2))) +(define ast-lambda-params (fn (n) (nth n 1))) +(define ast-lambda-body (fn (n) (nth n 2))) +(define ast-let-bindings (fn (n) (nth n 1))) +(define ast-let-body (fn (n) (nth n 2))) +(define ast-letrec-bindings (fn (n) (nth n 1))) +(define ast-letrec-body (fn (n) (nth n 2))) +(define ast-if-test (fn (n) (nth n 1))) +(define ast-if-then (fn (n) (nth n 2))) +(define ast-if-else (fn (n) (nth n 3))) +(define ast-match-clause-pattern (fn (n) (nth n 1))) +(define ast-match-clause-body (fn (n) (nth n 2))) +(define ast-module-name (fn (n) (nth n 1))) +(define ast-module-body (fn (n) (nth n 2))) +(define ast-import-name (fn (n) (nth n 1))) diff --git a/lib/guest/baseline/apl.json b/lib/guest/baseline/apl.json new file mode 100644 index 00000000..bb34f8ab --- /dev/null +++ b/lib/guest/baseline/apl.json @@ -0,0 +1,18 @@ +{ + "lang": "apl", + "captured": "2026-05-06T22:01:00Z", + "suite_command": "bash lib/apl/test.sh", + "totals": { + "pass": 73, + "fail": 0, + "total": 73 + }, + "suites": [ + { + "name": "all", + "pass": 73, + "fail": 0, + "total": 73 + } + ] +} diff --git a/lib/guest/baseline/common-lisp.json b/lib/guest/baseline/common-lisp.json new file mode 100644 index 00000000..8378c723 --- /dev/null +++ b/lib/guest/baseline/common-lisp.json @@ -0,0 +1,86 @@ +{ + "lang": "common-lisp", + "captured": "2026-05-06T22:59:46Z", + "suite_command": "bash lib/common-lisp/conformance.sh", + "totals": { + "pass": 518, + "fail": 0, + "total": 518 + }, + "suites": [ + { + "name": "Phase 1: tokenizer/reader", + "pass": 79, + "fail": 0, + "total": 79 + }, + { + "name": "Phase 1: parser/lambda-lists", + "pass": 31, + "fail": 0, + "total": 31 + }, + { + "name": "Phase 2: evaluator", + "pass": 182, + "fail": 0, + "total": 182 + }, + { + "name": "Phase 3: condition system", + "pass": 59, + "fail": 0, + "total": 59 + }, + { + "name": "Phase 3: restart-demo", + "pass": 7, + "fail": 0, + "total": 7 + }, + { + "name": "Phase 3: parse-recover", + "pass": 6, + "fail": 0, + "total": 6 + }, + { + "name": "Phase 3: interactive-debugger", + "pass": 7, + "fail": 0, + "total": 7 + }, + { + "name": "Phase 4: CLOS", + "pass": 41, + "fail": 0, + "total": 41 + }, + { + "name": "Phase 4: geometry", + "pass": 12, + "fail": 0, + "total": 12 + }, + { + "name": "Phase 4: mop-trace", + "pass": 13, + "fail": 0, + "total": 13 + }, + { + "name": "Phase 5: macros+LOOP", + "pass": 27, + "fail": 0, + "total": 27 + }, + { + "name": "Phase 6: stdlib", + "pass": 54, + "fail": 0, + "total": 54 + } + ], + "source_scoreboard": "lib/common-lisp/scoreboard.json", + "note": "Step 2: previous baseline (309) was lower because Phase 2 (evaluator, +182 tests) and Phase 6 (stdlib, +27 tests) results were under-counted by the original conformance.sh's parser. Re-running with prefix.sx loaded reveals true counts. No tests regressed." +} diff --git a/lib/guest/baseline/erlang.json b/lib/guest/baseline/erlang.json new file mode 100644 index 00000000..b5a67d25 --- /dev/null +++ b/lib/guest/baseline/erlang.json @@ -0,0 +1,67 @@ +{ + "lang": "erlang", + "captured": "2026-05-06T22:01:00Z", + "suite_command": "bash lib/erlang/conformance.sh", + "totals": { + "pass": 0, + "fail": 0, + "total": 0 + }, + "suites": [ + { + "name": "tokenize", + "pass": 0, + "fail": 0, + "total": 0 + }, + { + "name": "parse", + "pass": 0, + "fail": 0, + "total": 0 + }, + { + "name": "eval", + "pass": 0, + "fail": 0, + "total": 0 + }, + { + "name": "runtime", + "pass": 0, + "fail": 0, + "total": 0 + }, + { + "name": "ring", + "pass": 0, + "fail": 0, + "total": 0 + }, + { + "name": "ping-pong", + "pass": 0, + "fail": 0, + "total": 0 + }, + { + "name": "bank", + "pass": 0, + "fail": 0, + "total": 0 + }, + { + "name": "echo", + "pass": 0, + "fail": 0, + "total": 0 + }, + { + "name": "fib", + "pass": 0, + "fail": 0, + "total": 0 + } + ], + "source_scoreboard": "lib/erlang/scoreboard.json" +} diff --git a/lib/guest/baseline/forth.json b/lib/guest/baseline/forth.json new file mode 100644 index 00000000..9d1c7e08 --- /dev/null +++ b/lib/guest/baseline/forth.json @@ -0,0 +1,18 @@ +{ + "lang": "forth", + "captured": "2026-05-06T22:01:00Z", + "suite_command": "bash lib/forth/test.sh", + "totals": { + "pass": 64, + "fail": 0, + "total": 64 + }, + "suites": [ + { + "name": "all", + "pass": 64, + "fail": 0, + "total": 64 + } + ] +} diff --git a/lib/guest/baseline/haskell.json b/lib/guest/baseline/haskell.json new file mode 100644 index 00000000..16e94e30 --- /dev/null +++ b/lib/guest/baseline/haskell.json @@ -0,0 +1,122 @@ +{ + "lang": "haskell", + "captured": "2026-05-06T22:46:16Z", + "suite_command": "bash lib/haskell/conformance.sh", + "totals": { + "pass": 156, + "fail": 0, + "total": 156 + }, + "suites": [ + { + "name": "fib", + "pass": 2, + "fail": 0, + "total": 2 + }, + { + "name": "sieve", + "pass": 2, + "fail": 0, + "total": 2 + }, + { + "name": "quicksort", + "pass": 5, + "fail": 0, + "total": 5 + }, + { + "name": "nqueens", + "pass": 2, + "fail": 0, + "total": 2 + }, + { + "name": "calculator", + "pass": 5, + "fail": 0, + "total": 5 + }, + { + "name": "collatz", + "pass": 11, + "fail": 0, + "total": 11 + }, + { + "name": "palindrome", + "pass": 8, + "fail": 0, + "total": 8 + }, + { + "name": "maybe", + "pass": 12, + "fail": 0, + "total": 12 + }, + { + "name": "fizzbuzz", + "pass": 12, + "fail": 0, + "total": 12 + }, + { + "name": "anagram", + "pass": 9, + "fail": 0, + "total": 9 + }, + { + "name": "roman", + "pass": 14, + "fail": 0, + "total": 14 + }, + { + "name": "binary", + "pass": 12, + "fail": 0, + "total": 12 + }, + { + "name": "either", + "pass": 12, + "fail": 0, + "total": 12 + }, + { + "name": "primes", + "pass": 12, + "fail": 0, + "total": 12 + }, + { + "name": "zipwith", + "pass": 9, + "fail": 0, + "total": 9 + }, + { + "name": "matrix", + "pass": 8, + "fail": 0, + "total": 8 + }, + { + "name": "wordcount", + "pass": 7, + "fail": 0, + "total": 7 + }, + { + "name": "powers", + "pass": 14, + "fail": 0, + "total": 14 + } + ], + "source_scoreboard": "lib/haskell/scoreboard.json", + "note": "Step 1: previous baseline (0/18) was an artefact of the old conformance.sh bug \u2014 its (ok-len 3 ...) grep never matched, defaulting every program to 0 pass / 1 fail. Shared driver in Step 1 reads counters correctly." +} diff --git a/lib/guest/baseline/js.json b/lib/guest/baseline/js.json new file mode 100644 index 00000000..8e8f81ad --- /dev/null +++ b/lib/guest/baseline/js.json @@ -0,0 +1,75 @@ +{ + "lang": "js", + "captured": "2026-05-06T22:01:00Z", + "suite_command": "bash lib/js/conformance.sh", + "totals": { + "pass": 94, + "fail": 54, + "total": 148 + }, + "suites": [ + { + "name": "test262-slice", + "pass": 94, + "fail": 54, + "total": 148, + "failing_tests": [ + "arithmetic/bitnot", + "arithmetic/mixed_concat", + "async/await_promise_all", + "closures/sum_sq", + "coercion/implicit_str_add", + "collections/array_index", + "collections/array_nested", + "collections/string_index", + "functions/rest_param", + "loops/for_break", + "loops/for_continue", + "loops/nested_for", + "loops/while_basic", + "loops/while_break_infinite", + "objects/array_filter_reduce", + "objects/array_map", + "objects/array_method_chain", + "objects/array_mutate", + "objects/array_push_length", + "objects/arrow_lexical_this", + "objects/class_basic", + "objects/class_extend_chain", + "objects/class_inherit", + "objects/counter_closure", + "objects/in_operator", + "objects/instanceof", + "objects/method_this", + "objects/new_constructor", + "objects/object_mutate", + "objects/prototype_chain", + "objects/string_method", + "objects/string_slice", + "promises/executor_throws", + "promises/finally_passthrough", + "promises/microtask_ordering", + "promises/new_promise_reject", + "promises/new_promise_resolve", + "promises/promise_all", + "promises/promise_all_empty", + "promises/promise_all_nonpromise", + "promises/promise_all_reject", + "promises/promise_race", + "promises/promise_resolve_already_promise", + "promises/reject_catch", + "promises/resolve_adopts", + "promises/resolve_then", + "promises/then_chain", + "promises/then_throw_catch", + "statements/block_scope", + "statements/const_multi", + "statements/if_else_false", + "statements/if_else_true", + "statements/let_init", + "statements/var_decl" + ] + } + ], + "source_scoreboard": "lib/js/conformance.sh-output" +} diff --git a/lib/guest/baseline/lua.json b/lib/guest/baseline/lua.json new file mode 100644 index 00000000..f22e3338 --- /dev/null +++ b/lib/guest/baseline/lua.json @@ -0,0 +1,18 @@ +{ + "lang": "lua", + "captured": "2026-05-06T22:01:00Z", + "suite_command": "bash lib/lua/test.sh", + "totals": { + "pass": 185, + "fail": 0, + "total": 185 + }, + "suites": [ + { + "name": "all", + "pass": 185, + "fail": 0, + "total": 185 + } + ] +} diff --git a/lib/guest/baseline/prolog.json b/lib/guest/baseline/prolog.json new file mode 100644 index 00000000..9f2f16fd --- /dev/null +++ b/lib/guest/baseline/prolog.json @@ -0,0 +1,187 @@ +{ + "lang": "prolog", + "captured": "2026-05-06T22:01:00Z", + "suite_command": "bash lib/prolog/conformance.sh", + "totals": { + "pass": 590, + "fail": 0, + "total": 590 + }, + "suites": [ + { + "name": "parse", + "pass": 25, + "fail": 0, + "total": 25 + }, + { + "name": "unify", + "pass": 47, + "fail": 0, + "total": 47 + }, + { + "name": "clausedb", + "pass": 14, + "fail": 0, + "total": 14 + }, + { + "name": "solve", + "pass": 62, + "fail": 0, + "total": 62 + }, + { + "name": "operators", + "pass": 19, + "fail": 0, + "total": 19 + }, + { + "name": "dynamic", + "pass": 11, + "fail": 0, + "total": 11 + }, + { + "name": "findall", + "pass": 11, + "fail": 0, + "total": 11 + }, + { + "name": "term_inspect", + "pass": 14, + "fail": 0, + "total": 14 + }, + { + "name": "append", + "pass": 6, + "fail": 0, + "total": 6 + }, + { + "name": "reverse", + "pass": 6, + "fail": 0, + "total": 6 + }, + { + "name": "member", + "pass": 7, + "fail": 0, + "total": 7 + }, + { + "name": "nqueens", + "pass": 6, + "fail": 0, + "total": 6 + }, + { + "name": "family", + "pass": 10, + "fail": 0, + "total": 10 + }, + { + "name": "atoms", + "pass": 34, + "fail": 0, + "total": 34 + }, + { + "name": "query_api", + "pass": 16, + "fail": 0, + "total": 16 + }, + { + "name": "iso_predicates", + "pass": 29, + "fail": 0, + "total": 29 + }, + { + "name": "meta_predicates", + "pass": 25, + "fail": 0, + "total": 25 + }, + { + "name": "list_predicates", + "pass": 33, + "fail": 0, + "total": 33 + }, + { + "name": "meta_call", + "pass": 15, + "fail": 0, + "total": 15 + }, + { + "name": "set_predicates", + "pass": 15, + "fail": 0, + "total": 15 + }, + { + "name": "char_predicates", + "pass": 27, + "fail": 0, + "total": 27 + }, + { + "name": "io_predicates", + "pass": 24, + "fail": 0, + "total": 24 + }, + { + "name": "assert_rules", + "pass": 15, + "fail": 0, + "total": 15 + }, + { + "name": "string_agg", + "pass": 25, + "fail": 0, + "total": 25 + }, + { + "name": "advanced", + "pass": 21, + "fail": 0, + "total": 21 + }, + { + "name": "compiler", + "pass": 17, + "fail": 0, + "total": 17 + }, + { + "name": "cross_validate", + "pass": 17, + "fail": 0, + "total": 17 + }, + { + "name": "integration", + "pass": 20, + "fail": 0, + "total": 20 + }, + { + "name": "hs_bridge", + "pass": 19, + "fail": 0, + "total": 19 + } + ], + "source_scoreboard": "lib/prolog/scoreboard.json" +} diff --git a/lib/guest/baseline/ruby.json b/lib/guest/baseline/ruby.json new file mode 100644 index 00000000..32978498 --- /dev/null +++ b/lib/guest/baseline/ruby.json @@ -0,0 +1,18 @@ +{ + "lang": "ruby", + "captured": "2026-05-06T22:01:00Z", + "suite_command": "bash lib/ruby/test.sh", + "totals": { + "pass": 76, + "fail": 0, + "total": 76 + }, + "suites": [ + { + "name": "all", + "pass": 76, + "fail": 0, + "total": 76 + } + ] +} diff --git a/lib/guest/baseline/smalltalk.json b/lib/guest/baseline/smalltalk.json new file mode 100644 index 00000000..bc5b4ffd --- /dev/null +++ b/lib/guest/baseline/smalltalk.json @@ -0,0 +1,25 @@ +{ + "lang": "smalltalk", + "captured": "2026-05-06T22:01:00Z", + "suite_command": "bash lib/smalltalk/conformance.sh", + "totals": { + "pass": 625, + "fail": 4, + "total": 629 + }, + "suites": [ + { + "name": "all", + "pass": 625, + "fail": 4, + "total": 629 + }, + { + "name": "classic-corpus", + "pass": 4, + "fail": 1, + "total": 5 + } + ], + "source_scoreboard": "lib/smalltalk/scoreboard.json" +} diff --git a/lib/guest/baseline/tcl.json b/lib/guest/baseline/tcl.json new file mode 100644 index 00000000..94bb741e --- /dev/null +++ b/lib/guest/baseline/tcl.json @@ -0,0 +1,37 @@ +{ + "lang": "tcl", + "captured": "2026-05-06T22:01:00Z", + "suite_command": "bash lib/tcl/conformance.sh", + "totals": { + "pass": 3, + "fail": 1, + "total": 4 + }, + "suites": [ + { + "name": "assert", + "pass": 1, + "fail": 0, + "total": 1 + }, + { + "name": "event-loop", + "pass": 0, + "fail": 1, + "total": 1 + }, + { + "name": "for-each-line", + "pass": 1, + "fail": 0, + "total": 1 + }, + { + "name": "with-temp-var", + "pass": 1, + "fail": 0, + "total": 1 + } + ], + "source_scoreboard": "lib/tcl/scoreboard.json" +} diff --git a/lib/guest/conformance.sh b/lib/guest/conformance.sh new file mode 100755 index 00000000..7f0c6509 --- /dev/null +++ b/lib/guest/conformance.sh @@ -0,0 +1,221 @@ +#!/usr/bin/env bash +# lib/guest/conformance.sh — shared, config-driven conformance driver. +# +# Usage: +# bash lib/guest/conformance.sh +# +# The conf file is a bash file that sets: +# LANG_NAME e.g. prolog +# PRELOADS=( ... ) .sx files to load before any suite (path from repo root) +# SUITES=( ... ) colon-separated entries; format depends on MODE +# MODE "dict" or "counters" +# COUNTERS_PASS (counters mode) global symbol for the pass counter +# COUNTERS_FAIL (counters mode) global symbol for the fail counter +# TIMEOUT_PER_SUITE (optional, counters mode) seconds per suite, default 120 +# SCOREBOARD_DIR (optional) defaults to lib/$LANG_NAME +# +# It may override the bash functions emit_scoreboard_json / emit_scoreboard_md +# to produce the per-language scoreboard schema. Defaults are provided. +# +# Suite formats: +# MODE=dict — "name:test-file:(runner-fn)" +# The runner expression is evaluated and is expected to +# return a dict with :passed/:failed/:total. +# MODE=counters — "name:test-file" +# Each suite is run in a fresh sx_server session: preloads +# are loaded, then the test file, then counters are read. +# The suite is treated as starting from counters (0, 0). +# +# Output: +# Writes $SCOREBOARD_DIR/scoreboard.json and $SCOREBOARD_DIR/scoreboard.md. +# Exits 0 if every suite is green, 1 otherwise. + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +if [ "$#" -lt 1 ]; then + echo "usage: $0 " >&2 + exit 2 +fi + +CONF="$1" +if [ ! -f "$CONF" ]; then + echo "config not found: $CONF" >&2 + exit 2 +fi + +# Defaults — the conf file may override these. +LANG_NAME= +PRELOADS=() +SUITES=() +MODE=dict +COUNTERS_PASS= +COUNTERS_FAIL= +TIMEOUT_PER_SUITE=120 +SCOREBOARD_DIR= + +emit_scoreboard_json() { + # Generic schema. Per-lang configs override this for byte-equality with + # historical scoreboards. + local n=${#GC_NAMES[@]} i sep + printf '{\n' + printf ' "lang": "%s",\n' "$LANG_NAME" + printf ' "total_passed": %d,\n' "$GC_TOTAL_PASS" + printf ' "total_failed": %d,\n' "$GC_TOTAL_FAIL" + printf ' "total": %d,\n' "$GC_TOTAL" + printf ' "suites": [' + for ((i=0; i/dev/null || date)" + printf '}\n' +} + +emit_scoreboard_md() { + local n=${#GC_NAMES[@]} i status + printf '# %s scoreboard\n\n' "$LANG_NAME" + printf '**%d / %d passing** (%d failure(s)).\n\n' "$GC_TOTAL_PASS" "$GC_TOTAL" "$GC_TOTAL_FAIL" + printf '| Suite | Passed | Total | Status |\n' + printf '|-------|--------|-------|--------|\n' + for ((i=0; i&2 + exit 2 +fi +SCOREBOARD_DIR="${SCOREBOARD_DIR:-lib/$LANG_NAME}" + +SX="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX" ]; then + MAIN_ROOT=$(git worktree list 2>/dev/null | head -1 | awk '{print $1}') + if [ -n "${MAIN_ROOT:-}" ] && [ -x "$MAIN_ROOT/$SX" ]; then + SX="$MAIN_ROOT/$SX" + else + echo "ERROR: sx_server.exe not found (set SX_SERVER to override)." >&2 + exit 2 + fi +fi + +GC_NAMES=() +GC_PASS=() +GC_FAIL=() +GC_TOTAL_S=() + +parse_result_line() { + # Match a (gc-result "name" P F T) line. + local line="$1" + if [[ "$line" =~ ^\(gc-result\ \"([^\"]+)\"\ ([0-9]+)\ ([0-9]+)\ ([0-9]+)\)$ ]]; then + GC_NAMES+=("${BASH_REMATCH[1]}") + GC_PASS+=("${BASH_REMATCH[2]}") + GC_FAIL+=("${BASH_REMATCH[3]}") + GC_TOTAL_S+=("${BASH_REMATCH[4]}") + return 0 + fi + return 1 +} + +case "$MODE" in + dict) + SCRIPT='(epoch 1) +' + for f in "${PRELOADS[@]}"; do + SCRIPT+='(load "'"$f"'") +' + done + SCRIPT+='(load "lib/guest/conformance.sx") +' + for entry in "${SUITES[@]}"; do + IFS=: read -r _ file _ <<< "$entry" + SCRIPT+='(load "'"$file"'") +' + done + SCRIPT+='(epoch 2) +' + for entry in "${SUITES[@]}"; do + IFS=: read -r name _ runner <<< "$entry" + SCRIPT+='(eval "(gc-dict-result \"'"$name"'\" '"$runner"')") +' + done + OUTPUT=$(printf '%s' "$SCRIPT" | "$SX" 2>&1) + expected=${#SUITES[@]} + matched=0 + while IFS= read -r line; do + if parse_result_line "$line"; then + matched=$((matched + 1)) + fi + done <<< "$OUTPUT" + if [ "$matched" -ne "$expected" ]; then + echo "Expected $expected suite results, got $matched" >&2 + echo "---- raw output ----" >&2 + printf '%s\n' "$OUTPUT" >&2 + exit 3 + fi + ;; + counters) + if [ -z "$COUNTERS_PASS" ] || [ -z "$COUNTERS_FAIL" ]; then + echo "MODE=counters requires COUNTERS_PASS and COUNTERS_FAIL in $CONF" >&2 + exit 2 + fi + for entry in "${SUITES[@]}"; do + IFS=: read -r name file <<< "$entry" + TMPFILE=$(mktemp) + { + printf '(epoch 1)\n' + for f in "${PRELOADS[@]}"; do printf '(load "%s")\n' "$f"; done + printf '(load "lib/guest/conformance.sx")\n' + printf '(epoch 2)\n' + printf '(load "%s")\n' "$file" + printf '(epoch 3)\n' + printf '(eval "(gc-counters-result \\"%s\\" 0 0 %s %s)")\n' \ + "$name" "$COUNTERS_PASS" "$COUNTERS_FAIL" + } > "$TMPFILE" + OUTPUT=$(timeout "$TIMEOUT_PER_SUITE" "$SX" < "$TMPFILE" 2>&1 || true) + rm -f "$TMPFILE" + result=$(printf '%s\n' "$OUTPUT" | grep -E '^\(gc-result ' | tail -1 || true) + if [ -n "$result" ] && parse_result_line "$result"; then + : + else + # Suite hung or crashed before emitting a result. Record 0/1 so it + # shows up as a failure rather than vanishing. + GC_NAMES+=("$name") + GC_PASS+=(0) + GC_FAIL+=(1) + GC_TOTAL_S+=(1) + fi + done + ;; + *) + echo "Unknown MODE=$MODE in $CONF (expected dict|counters)" >&2 + exit 2 + ;; +esac + +GC_TOTAL_PASS=0 +GC_TOTAL_FAIL=0 +GC_TOTAL=0 +for ((i=0; i<${#GC_NAMES[@]}; i++)); do + GC_TOTAL_PASS=$((GC_TOTAL_PASS + GC_PASS[i])) + GC_TOTAL_FAIL=$((GC_TOTAL_FAIL + GC_FAIL[i])) + GC_TOTAL=$((GC_TOTAL + GC_TOTAL_S[i])) +done + +mkdir -p "$SCOREBOARD_DIR" +emit_scoreboard_json > "$SCOREBOARD_DIR/scoreboard.json" +emit_scoreboard_md > "$SCOREBOARD_DIR/scoreboard.md" + +if [ "$GC_TOTAL_FAIL" -gt 0 ]; then + echo "$GC_TOTAL_FAIL failure(s) across $GC_TOTAL tests" >&2 + exit 1 +fi +echo "All $GC_TOTAL tests pass." diff --git a/lib/guest/conformance.sx b/lib/guest/conformance.sx new file mode 100644 index 00000000..323bfb6f --- /dev/null +++ b/lib/guest/conformance.sx @@ -0,0 +1,40 @@ +;; lib/guest/conformance.sx — shared helpers for the guest conformance driver. +;; +;; The bash driver lib/guest/conformance.sh loads this file and then for each +;; suite emits an (eval "...") form whose result is a tagged list: +;; +;; (gc-result NAME PASSED FAILED TOTAL) +;; +;; The driver greps these from sx_server's output and aggregates them. +;; +;; Two suite shapes are supported: +;; +;; :dict — runner expression returns a dict with :passed/:failed/:total. +;; (gc-dict-result "parse" (pl-parse-tests-run!)) +;; +;; :counters — runner has no return value, mutates pass/fail global counters. +;; (gc-counters-result NAME P0 F0 PASS FAIL) +;; where P0/F0 are the counters captured BEFORE the suite ran +;; and PASS/FAIL are the counters AFTER. + +(define + gc-dict-result + (fn + (name r) + (list + (quote gc-result) + name + (get r :passed) + (get r :failed) + (get r :total)))) + +(define + gc-counters-result + (fn + (name p0 f0 p1 f1) + (list + (quote gc-result) + name + (- p1 p0) + (- f1 f0) + (- (+ p1 f1) (+ p0 f0))))) diff --git a/lib/guest/hm.sx b/lib/guest/hm.sx new file mode 100644 index 00000000..602c99a7 --- /dev/null +++ b/lib/guest/hm.sx @@ -0,0 +1,180 @@ +;; lib/guest/hm.sx — Hindley-Milner type-inference foundations. +;; +;; Builds on lib/guest/match.sx (terms + unify) and ast.sx (canonical +;; AST shapes). This file ships the ALGEBRA — types, schemes, free +;; type-vars, generalize / instantiate, substitution composition — so a +;; full Algorithm W (or J) can be assembled on top either inside this +;; file or in a host-specific consumer (haskell/infer.sx, +;; lib/ocaml/types.sx, …). +;; +;; Per the brief the second consumer for this step is OCaml-on-SX +;; Phase 5 (paired sequencing). Until that lands, the algebra is the +;; deliverable; the host-flavoured assembly (lambda / app / let +;; inference rules with substitution threading) lives in the host. +;; +;; Types +;; ----- +;; A type is a canonical match.sx term — type variables use mk-var, +;; type constructors use mk-ctor: +;; (hm-tv NAME) type variable +;; (hm-arrow A B) A -> B +;; (hm-con NAME ARGS) named n-ary constructor +;; (hm-int) / (hm-bool) / (hm-string) primitive constructors +;; +;; Schemes +;; ------- +;; (hm-scheme VARS TYPE) ∀ VARS . TYPE +;; (hm-monotype TYPE) empty quantifier +;; (hm-scheme? S) (hm-scheme-vars S) (hm-scheme-type S) +;; +;; Free type variables +;; ------------------- +;; (hm-ftv TYPE) names occurring in TYPE +;; (hm-ftv-scheme S) free names (minus quantifiers) +;; (hm-ftv-env ENV) free across an env (name -> scheme) +;; +;; Substitution +;; ------------ +;; (hm-apply SUBST TYPE) substitute through a type +;; (hm-apply-scheme SUBST S) leaves bound vars alone +;; (hm-apply-env SUBST ENV) +;; (hm-compose S2 S1) apply S1 then S2 +;; +;; Generalize / Instantiate +;; ------------------------ +;; (hm-generalize TYPE ENV) → scheme over ftv(t) - ftv(env) +;; (hm-instantiate SCHEME COUNTER) → fresh-var instance +;; (hm-fresh-tv COUNTER) → (:var "tN"), bumps COUNTER +;; +;; Inference (literal only — the rest of Algorithm W lives in the host) +;; -------------------------------------------------------------------- +;; (hm-infer-literal EXPR) → {:subst {} :type T} +;; +;; A complete Algorithm W consumes this kit by assembling lambda / app +;; / let rules in the host language file. + +(define hm-tv (fn (name) (list :var name))) +(define hm-con (fn (name args) (list :ctor name args))) +(define hm-arrow (fn (a b) (hm-con "->" (list a b)))) +(define hm-int (fn () (hm-con "Int" (list)))) +(define hm-bool (fn () (hm-con "Bool" (list)))) +(define hm-string (fn () (hm-con "String" (list)))) + +(define hm-scheme (fn (vars t) (list :scheme vars t))) +(define hm-monotype (fn (t) (hm-scheme (list) t))) +(define hm-scheme? (fn (s) (and (list? s) (not (empty? s)) (= (first s) :scheme)))) +(define hm-scheme-vars (fn (s) (nth s 1))) +(define hm-scheme-type (fn (s) (nth s 2))) + +(define + hm-fresh-tv + (fn (counter) + (let ((n (first counter))) + (begin + (set-nth! counter 0 (+ n 1)) + (hm-tv (str "t" (+ n 1))))))) + +(define + hm-ftv-acc + (fn (t acc) + (cond + ((is-var? t) + (if (some (fn (n) (= n (var-name t))) acc) acc (cons (var-name t) acc))) + ((is-ctor? t) + (let ((a acc)) + (begin + (for-each (fn (x) (set! a (hm-ftv-acc x a))) (ctor-args t)) + a))) + (:else acc)))) + +(define hm-ftv (fn (t) (hm-ftv-acc t (list)))) + +(define + hm-ftv-scheme + (fn (s) + (let ((qs (hm-scheme-vars s)) + (all (hm-ftv (hm-scheme-type s)))) + (filter (fn (n) (not (some (fn (q) (= q n)) qs))) all)))) + +(define + hm-ftv-env + (fn (env) + (let ((acc (list))) + (begin + (for-each + (fn (k) + (for-each + (fn (n) + (when (not (some (fn (m) (= m n)) acc)) + (set! acc (cons n acc)))) + (hm-ftv-scheme (get env k)))) + (keys env)) + acc)))) + +(define hm-apply (fn (subst t) (walk* t subst))) + +(define + hm-apply-scheme + (fn (subst s) + (let ((qs (hm-scheme-vars s)) + (d {})) + (begin + (for-each + (fn (k) + (when (not (some (fn (q) (= q k)) qs)) + (dict-set! d k (get subst k)))) + (keys subst)) + (hm-scheme qs (walk* (hm-scheme-type s) d)))))) + +(define + hm-apply-env + (fn (subst env) + (let ((d {})) + (begin + (for-each + (fn (k) (dict-set! d k (hm-apply-scheme subst (get env k)))) + (keys env)) + d)))) + +(define + hm-compose + (fn (s2 s1) + (let ((d {})) + (begin + (for-each (fn (k) (dict-set! d k (walk* (get s1 k) s2))) (keys s1)) + (for-each + (fn (k) (when (not (has-key? d k)) (dict-set! d k (get s2 k)))) + (keys s2)) + d)))) + +(define + hm-generalize + (fn (t env) + (let ((tvars (hm-ftv t)) + (evars (hm-ftv-env env))) + (let ((qs (filter (fn (n) (not (some (fn (m) (= m n)) evars))) tvars))) + (hm-scheme qs t))))) + +(define + hm-instantiate + (fn (s counter) + (let ((qs (hm-scheme-vars s)) + (subst {})) + (begin + (for-each + (fn (q) (set! subst (assoc subst q (hm-fresh-tv counter)))) + qs) + (walk* (hm-scheme-type s) subst))))) + +;; Literal inference — the only AST kind whose typing rule is closed +;; in the kit. Lambda / app / let live in host code so the host's own +;; AST conventions stay untouched. +(define + hm-infer-literal + (fn (expr) + (let ((v (ast-literal-value expr))) + (cond + ((number? v) {:subst {} :type (hm-int)}) + ((string? v) {:subst {} :type (hm-string)}) + ((boolean? v) {:subst {} :type (hm-bool)}) + (:else (error (str "hm-infer-literal: unknown kind: " v))))))) diff --git a/lib/guest/layout.sx b/lib/guest/layout.sx new file mode 100644 index 00000000..cf4db72c --- /dev/null +++ b/lib/guest/layout.sx @@ -0,0 +1,145 @@ +;; lib/guest/layout.sx — configurable off-side / layout-sensitive lexer. +;; +;; Inserts virtual open / close / separator tokens based on indentation. +;; Configurable enough to encode either the Haskell 98 layout rule (let / +;; where / do / of opens a virtual brace at the next token's column) or +;; a Python-ish indent / dedent rule (a colon at the end of a line opens +;; a block at the next non-blank line's column). +;; +;; Token shape (input + output) +;; ---------------------------- +;; Each token is a dict {:type :value :line :col …}. The kit reads +;; only :type / :value / :line / :col and passes everything else +;; through. The input stream MUST be free of newline filler tokens +;; (preprocess them away with your tokenizer) — line breaks are detected +;; by comparing :line of consecutive tokens. +;; +;; Config +;; ------ +;; :open-keywords list of strings; a token whose :value matches +;; opens a new layout block at the next token's +;; column (Haskell: let/where/do/of). +;; :open-trailing-fn (fn (tok) -> bool) — alternative trigger that +;; fires AFTER the token is emitted. Use for +;; Python-style trailing `:`. +;; :open-token / :close-token / :sep-token +;; templates {:type :value} merged with :line and +;; :col when virtual tokens are emitted. +;; :explicit-open? (fn (tok) -> bool) — if the next token after a +;; trigger satisfies this, suppress virtual layout +;; for that block (Haskell: `{`). +;; :module-prelude? if true, wrap whole input in an implicit block +;; at the first token's column (Haskell yes, +;; Python no). +;; +;; Public entry +;; ------------ +;; (layout-pass cfg tokens) -> tokens with virtual layout inserted. + +(define + layout-mk-virtual + (fn (template line col) + (assoc (assoc template :line line) :col col))) + +(define + layout-is-open-kw? + (fn (tok open-kws) + (and (= (get tok :type) "reserved") + (some (fn (k) (= k (get tok :value))) open-kws)))) + +(define + layout-pass + (fn (cfg tokens) + (let ((open-kws (get cfg :open-keywords)) + (trailing-fn (get cfg :open-trailing-fn)) + (open-tmpl (get cfg :open-token)) + (close-tmpl (get cfg :close-token)) + (sep-tmpl (get cfg :sep-token)) + (mod-prelude? (get cfg :module-prelude?)) + (expl?-fn (get cfg :explicit-open?)) + (out (list)) + (stack (list)) + (n (len tokens)) + (i 0) + (prev-line -1) + (pending-open false) + (just-opened false)) + (define + emit-closes-while-greater + (fn (col line) + (when (and (not (empty? stack)) (> (first stack) col)) + (do + (append! out (layout-mk-virtual close-tmpl line col)) + (set! stack (rest stack)) + (emit-closes-while-greater col line))))) + (define + emit-pending-open + (fn (line col) + (do + (append! out (layout-mk-virtual open-tmpl line col)) + (set! stack (cons col stack)) + (set! pending-open false) + (set! just-opened true)))) + (define + layout-step + (fn () + (when (< i n) + (let ((tok (nth tokens i))) + (let ((line (get tok :line)) (col (get tok :col))) + (cond + (pending-open + (cond + ((and (not (= expl?-fn nil)) (expl?-fn tok)) + (do + (set! pending-open false) + (append! out tok) + (set! prev-line line) + (set! i (+ i 1)) + (layout-step))) + (:else + (do + (emit-pending-open line col) + (layout-step))))) + (:else + (let ((on-fresh-line? (and (> prev-line 0) (> line prev-line)))) + (do + (when on-fresh-line? + (let ((stack-before stack)) + (begin + (emit-closes-while-greater col line) + (when (and (not (empty? stack)) + (= (first stack) col) + (not just-opened) + ;; suppress separator if a dedent fired + ;; — the dedent is itself the separator + (= (len stack) (len stack-before))) + (append! out (layout-mk-virtual sep-tmpl line col)))))) + (set! just-opened false) + (append! out tok) + (set! prev-line line) + (set! i (+ i 1)) + (cond + ((layout-is-open-kw? tok open-kws) + (set! pending-open true)) + ((and (not (= trailing-fn nil)) (trailing-fn tok)) + (set! pending-open true))) + (layout-step)))))))))) + (begin + ;; Module prelude: implicit layout block at the first token's column. + (when (and mod-prelude? (> n 0)) + (let ((tok (nth tokens 0))) + (do + (append! out (layout-mk-virtual open-tmpl (get tok :line) (get tok :col))) + (set! stack (cons (get tok :col) stack)) + (set! just-opened true)))) + (layout-step) + ;; EOF: close every remaining block. + (define close-rest + (fn () + (when (not (empty? stack)) + (do + (append! out (layout-mk-virtual close-tmpl 0 0)) + (set! stack (rest stack)) + (close-rest))))) + (close-rest) + out)))) diff --git a/lib/guest/lex.sx b/lib/guest/lex.sx new file mode 100644 index 00000000..5894dffa --- /dev/null +++ b/lib/guest/lex.sx @@ -0,0 +1,67 @@ +;; lib/guest/lex.sx — character-class predicates and token primitives shared +;; across guest tokenisers. +;; +;; All predicates are nil-safe — they accept nil (end-of-input) and return +;; false. This matches the convention used by the existing per-language +;; tokenisers (cur returns nil at EOF). +;; +;; Char classes +;; ------------ +;; lex-digit? — 0-9 +;; lex-hex-digit? — 0-9, a-f, A-F +;; lex-alpha? — a-z, A-Z (alias: lex-letter?) +;; lex-alnum? — alpha or digit +;; lex-ident-start? — alpha or underscore +;; lex-ident-char? — ident-start or digit +;; lex-space? — " ", "\t", "\r" (no newline) +;; lex-whitespace? — " ", "\t", "\r", "\n" (includes newline) +;; +;; Token record +;; ------------ +;; (lex-make-token TYPE VALUE POS) — {:type :value :pos} +;; (lex-make-token-spanning TYPE VALUE POS END) +;; — {:type :value :pos :end} +;; (lex-token-type TOK) +;; (lex-token-value TOK) +;; (lex-token-pos TOK) + +(define lex-digit? (fn (c) (and (not (= c nil)) (>= c "0") (<= c "9")))) + +(define + lex-hex-digit? + (fn + (c) + (and + (not (= c nil)) + (or + (lex-digit? c) + (and (>= c "a") (<= c "f")) + (and (>= c "A") (<= c "F")))))) + +(define + lex-alpha? + (fn + (c) + (and + (not (= c nil)) + (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))) + +(define lex-letter? lex-alpha?) + +(define lex-alnum? (fn (c) (or (lex-alpha? c) (lex-digit? c)))) + +(define lex-ident-start? (fn (c) (or (lex-alpha? c) (= c "_")))) + +(define lex-ident-char? (fn (c) (or (lex-ident-start? c) (lex-digit? c)))) + +(define lex-space? (fn (c) (or (= c " ") (= c "\t") (= c "\r")))) + +(define lex-whitespace? (fn (c) (or (lex-space? c) (= c "\n")))) + +(define lex-make-token (fn (type value pos) {:pos pos :value value :type type})) + +(define lex-make-token-spanning (fn (type value pos end) {:pos pos :end end :value value :type type})) + +(define lex-token-type (fn (tok) (get tok :type))) +(define lex-token-value (fn (tok) (get tok :value))) +(define lex-token-pos (fn (tok) (get tok :pos))) diff --git a/lib/guest/match.sx b/lib/guest/match.sx new file mode 100644 index 00000000..8c1cb0c2 --- /dev/null +++ b/lib/guest/match.sx @@ -0,0 +1,185 @@ +;; lib/guest/match.sx — pure pattern-match + unification kit. +;; +;; Shipped for miniKanren / Datalog / future logic-flavoured guests that +;; want immutable unification without writing it from scratch. The two +;; existing prolog/haskell engines stay as-is — porting them in place +;; risks the 746 tests they currently pass; consumers can migrate +;; gradually via the converters in lib/guest/ast.sx. +;; +;; Term shapes (canonical wire format) +;; ----------------------------------- +;; var (:var NAME) NAME a string +;; constructor (:ctor HEAD ARGS) HEAD a string, ARGS a list of terms +;; literal number / string / boolean / nil +;; +;; Guests with their own shape pass adapter callbacks via the cfg arg — +;; see (unify-with cfg ...) and (match-pat-with cfg ...) below. The +;; default canonical entry points (unify / match-pat) use the wire shape. +;; +;; Substitution / env +;; ------------------ +;; A substitution is a SX dict mapping VAR-NAME → term. There are no +;; trails, no mutation: each step either returns an extended dict or nil. +;; +;; (empty-subst) → {} +;; (walk term s) → term with top-level vars resolved +;; (walk* term s) → term with all vars resolved (recursive) +;; (extend name term s) → s with NAME → term added +;; (occurs? name term s) → bool +;; +;; Unify (symmetric, miniKanren-flavour) +;; ------------------------------------- +;; (unify u v s) → extended subst or nil +;; (unify-with cfg u v s) → ditto, with adapter callbacks: +;; :var? :var-name :ctor? :ctor-head +;; :ctor-args :occurs-check? +;; +;; Match (asymmetric, haskell-flavour: pattern → value, vars only in pat) +;; --------------------------------------------------------------------- +;; (match-pat pat val env) → extended env or nil +;; (match-pat-with cfg pat val env) + +(define mk-var (fn (name) (list :var name))) +(define mk-ctor (fn (head args) (list :ctor head args))) + +(define is-var? (fn (t) (and (list? t) (not (empty? t)) (= (first t) :var)))) +(define is-ctor? (fn (t) (and (list? t) (not (empty? t)) (= (first t) :ctor)))) +(define var-name (fn (t) (nth t 1))) +(define ctor-head (fn (t) (nth t 1))) +(define ctor-args (fn (t) (nth t 2))) + +(define empty-subst (fn () {})) + +(define + walk + (fn (t s) + (if (and (is-var? t) (has-key? s (var-name t))) + (walk (get s (var-name t)) s) + t))) + +(define + walk* + (fn (t s) + (let ((w (walk t s))) + (cond + ((is-ctor? w) + (mk-ctor (ctor-head w) (map (fn (a) (walk* a s)) (ctor-args w)))) + (:else w))))) + +(define + extend + (fn (name term s) + (assoc s name term))) + +(define + occurs? + (fn (name term s) + (let ((w (walk term s))) + (cond + ((is-var? w) (= (var-name w) name)) + ((is-ctor? w) (some (fn (a) (occurs? name a s)) (ctor-args w))) + (:else false))))) + +(define + unify-with + (fn (cfg u v s) + (let ((var?-fn (get cfg :var?)) + (var-name-fn (get cfg :var-name)) + (ctor?-fn (get cfg :ctor?)) + (ctor-head-fn (get cfg :ctor-head)) + (ctor-args-fn (get cfg :ctor-args)) + (occurs?-on (get cfg :occurs-check?))) + (let ((wu (walk-with cfg u s)) + (wv (walk-with cfg v s))) + (cond + ((and (var?-fn wu) (var?-fn wv) (= (var-name-fn wu) (var-name-fn wv))) s) + ((var?-fn wu) + (if (and occurs?-on (occurs-with cfg (var-name-fn wu) wv s)) + nil + (extend (var-name-fn wu) wv s))) + ((var?-fn wv) + (if (and occurs?-on (occurs-with cfg (var-name-fn wv) wu s)) + nil + (extend (var-name-fn wv) wu s))) + ((and (ctor?-fn wu) (ctor?-fn wv)) + (if (= (ctor-head-fn wu) (ctor-head-fn wv)) + (unify-list-with + cfg + (ctor-args-fn wu) + (ctor-args-fn wv) + s) + nil)) + (:else (if (= wu wv) s nil))))))) + +(define + walk-with + (fn (cfg t s) + (if (and ((get cfg :var?) t) (has-key? s ((get cfg :var-name) t))) + (walk-with cfg (get s ((get cfg :var-name) t)) s) + t))) + +(define + occurs-with + (fn (cfg name term s) + (let ((w (walk-with cfg term s))) + (cond + (((get cfg :var?) w) (= ((get cfg :var-name) w) name)) + (((get cfg :ctor?) w) + (some (fn (a) (occurs-with cfg name a s)) ((get cfg :ctor-args) w))) + (:else false))))) + +(define + unify-list-with + (fn (cfg xs ys s) + (cond + ((and (empty? xs) (empty? ys)) s) + ((or (empty? xs) (empty? ys)) nil) + (:else + (let ((s2 (unify-with cfg (first xs) (first ys) s))) + (if (= s2 nil) + nil + (unify-list-with cfg (rest xs) (rest ys) s2))))))) + +(define canonical-cfg + {:var? is-var? :var-name var-name + :ctor? is-ctor? :ctor-head ctor-head :ctor-args ctor-args + :occurs-check? true}) + +(define unify (fn (u v s) (unify-with canonical-cfg u v s))) + +;; Asymmetric pattern match (haskell-style): only patterns may contain vars; +;; values are concrete. On a var pattern, bind name to value. +(define + match-pat-with + (fn (cfg pat val env) + (let ((var?-fn (get cfg :var?)) + (var-name-fn (get cfg :var-name)) + (ctor?-fn (get cfg :ctor?)) + (ctor-head-fn (get cfg :ctor-head)) + (ctor-args-fn (get cfg :ctor-args))) + (cond + ((var?-fn pat) (extend (var-name-fn pat) val env)) + ((and (ctor?-fn pat) (ctor?-fn val)) + (if (= (ctor-head-fn pat) (ctor-head-fn val)) + (match-list-pat-with + cfg + (ctor-args-fn pat) + (ctor-args-fn val) + env) + nil)) + ((ctor?-fn pat) nil) + (:else (if (= pat val) env nil)))))) + +(define + match-list-pat-with + (fn (cfg pats vals env) + (cond + ((and (empty? pats) (empty? vals)) env) + ((or (empty? pats) (empty? vals)) nil) + (:else + (let ((env2 (match-pat-with cfg (first pats) (first vals) env))) + (if (= env2 nil) + nil + (match-list-pat-with cfg (rest pats) (rest vals) env2))))))) + +(define match-pat (fn (pat val env) (match-pat-with canonical-cfg pat val env))) diff --git a/lib/guest/pratt.sx b/lib/guest/pratt.sx new file mode 100644 index 00000000..24138697 --- /dev/null +++ b/lib/guest/pratt.sx @@ -0,0 +1,28 @@ +;; lib/guest/pratt.sx — operator-table format + lookup for Pratt-style +;; precedence climbing. +;; +;; The climbing loop stays per-language because the two canaries use +;; opposite conventions (Lua: higher prec = tighter; Prolog: lower prec = +;; tighter, with xfx/xfy/yfx assoc tags). Forcing a single loop adds +;; callback indirection that obscures more than it shares. +;; +;; What IS shared and gets extracted: the operator-table format and lookup. +;; "Grammar is a dict, not hardcoded cond." +;; +;; Entry shape: (NAME PREC ASSOC). +;; NAME — string, the operator's source token. +;; PREC — integer, in the host's own convention. +;; ASSOC — :left | :right | :none for languages with traditional +;; associativity, or "xfx" / "xfy" / "yfx" for Prolog-style. + +(define + pratt-op-lookup + (fn (table name) + (cond + ((empty? table) nil) + ((= (first (first table)) name) (first table)) + (:else (pratt-op-lookup (rest table) name))))) + +(define pratt-op-name (fn (entry) (first entry))) +(define pratt-op-prec (fn (entry) (nth entry 1))) +(define pratt-op-assoc (fn (entry) (nth entry 2))) diff --git a/lib/guest/prefix.sx b/lib/guest/prefix.sx new file mode 100644 index 00000000..7138bdd8 --- /dev/null +++ b/lib/guest/prefix.sx @@ -0,0 +1,46 @@ +;; lib/guest/prefix.sx — prefix-rename macro. +;; +;; A guest runtime often re-exports a stretch of host primitives under a +;; language-specific prefix. The prefix-rename macro replaces the repeated +;; (define lang-foo foo) boilerplate with a single declarative call. +;; +;; Two entry shapes are supported: +;; +;; (prefix-rename "cl-" '(gcd lcm expt floor truncate)) +;; ;; expands to (begin (define cl-gcd gcd) +;; ;; (define cl-lcm lcm) ...) +;; +;; (prefix-rename "cl-" +;; '((mod modulo) +;; (arrayp? vector?) +;; (ceiling ceil))) +;; ;; expands to (begin (define cl-mod modulo) +;; ;; (define cl-arrayp? vector?) +;; ;; (define cl-ceiling ceil)) +;; +;; Mixed lists are supported — bare symbols are same-name aliases, two-element +;; lists are (alias target) pairs. + +(defmacro + prefix-rename + (prefix entries-q) + (let + ((entries (nth entries-q 1))) + (cons + (quote begin) + (map + (fn + (entry) + (cond + ((= (type-of entry) "symbol") + (list + (quote define) + (make-symbol (str prefix (symbol-name entry))) + entry)) + ((and (list? entry) (= (len entry) 2)) + (list + (quote define) + (make-symbol (str prefix (symbol-name (first entry)))) + (nth entry 1))) + (:else (error (str "prefix-rename: invalid entry " entry))))) + entries)))) diff --git a/lib/guest/tests/ast.sx b/lib/guest/tests/ast.sx new file mode 100644 index 00000000..7f8f17c1 --- /dev/null +++ b/lib/guest/tests/ast.sx @@ -0,0 +1,63 @@ +;; lib/guest/tests/ast.sx — exercises every constructor / predicate / +;; accessor in lib/guest/ast.sx so future ports have a stable contract +;; to point at. + +(define gast-test-pass 0) +(define gast-test-fail 0) +(define gast-test-fails (list)) + +(define + gast-test + (fn (name actual expected) + (if (= actual expected) + (set! gast-test-pass (+ gast-test-pass 1)) + (begin + (set! gast-test-fail (+ gast-test-fail 1)) + (append! gast-test-fails {:name name :expected expected :actual actual}))))) + +;; Constructors round-trip. +(gast-test "literal-int" (ast-literal-value (ast-literal 42)) 42) +(gast-test "literal-str" (ast-literal-value (ast-literal "hi")) "hi") +(gast-test "literal-bool" (ast-literal-value (ast-literal true)) true) +(gast-test "var-name" (ast-var-name (ast-var "x")) "x") +(gast-test "app-fn" (ast-app-fn (ast-app (ast-var "f") (list (ast-literal 1)))) (ast-var "f")) +(gast-test "app-args-len" (len (ast-app-args (ast-app (ast-var "f") (list (ast-literal 1))))) 1) +(gast-test "lambda-params" (ast-lambda-params (ast-lambda (list "x" "y") (ast-var "x"))) (list "x" "y")) +(gast-test "lambda-body" (ast-lambda-body (ast-lambda (list "x") (ast-var "x"))) (ast-var "x")) +(gast-test "let-bindings" (len (ast-let-bindings (ast-let (list {:name "x" :value (ast-literal 1)}) (ast-var "x")))) 1) +(gast-test "letrec-body" (ast-letrec-body (ast-letrec (list) (ast-literal 0))) (ast-literal 0)) +(gast-test "if-test" (ast-if-test (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal true)) +(gast-test "if-then" (ast-if-then (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal 1)) +(gast-test "if-else" (ast-if-else (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal 0)) +(gast-test "match-pattern" (ast-match-clause-pattern (ast-match-clause "P" (ast-literal 1))) "P") +(gast-test "match-body" (ast-match-clause-body (ast-match-clause "P" (ast-literal 1))) (ast-literal 1)) +(gast-test "module-name" (ast-module-name (ast-module "m" (list))) "m") +(gast-test "import-name" (ast-import-name (ast-import "lib/foo")) "lib/foo") + +;; Predicates fire only on matching kinds. +(gast-test "is-literal" (ast-literal? (ast-literal 1)) true) +(gast-test "not-literal" (ast-literal? (ast-var "x")) false) +(gast-test "is-var" (ast-var? (ast-var "x")) true) +(gast-test "is-app" (ast-app? (ast-app (ast-var "f") (list))) true) +(gast-test "is-lambda" (ast-lambda? (ast-lambda (list) (ast-literal 0))) true) +(gast-test "is-let" (ast-let? (ast-let (list) (ast-literal 0))) true) +(gast-test "is-letrec" (ast-letrec? (ast-letrec (list) (ast-literal 0))) true) +(gast-test "is-if" (ast-if? (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) true) +(gast-test "is-match" (ast-match-clause? (ast-match-clause "P" (ast-literal 1))) true) +(gast-test "is-module" (ast-module? (ast-module "m" (list))) true) +(gast-test "is-import" (ast-import? (ast-import "x")) true) + +;; ast? recognises any canonical node. +(gast-test "ast?-literal" (ast? (ast-literal 0)) true) +(gast-test "ast?-foreign" (ast? (list "lua-num" 0)) false) +(gast-test "ast?-non-list" (ast? 42) false) + +;; ast-kind dispatch. +(gast-test "kind-literal" (ast-kind (ast-literal 0)) :literal) +(gast-test "kind-import" (ast-kind (ast-import "x")) :import) + +(define gast-tests-run! + (fn () + {:passed gast-test-pass + :failed gast-test-fail + :total (+ gast-test-pass gast-test-fail)})) diff --git a/lib/guest/tests/hm.sx b/lib/guest/tests/hm.sx new file mode 100644 index 00000000..cf2f0f31 --- /dev/null +++ b/lib/guest/tests/hm.sx @@ -0,0 +1,89 @@ +;; lib/guest/tests/hm.sx — exercises lib/guest/hm.sx algebra. + +(define ghm-test-pass 0) +(define ghm-test-fail 0) +(define ghm-test-fails (list)) + +(define + ghm-test + (fn (name actual expected) + (if (= actual expected) + (set! ghm-test-pass (+ ghm-test-pass 1)) + (begin + (set! ghm-test-fail (+ ghm-test-fail 1)) + (append! ghm-test-fails {:name name :expected expected :actual actual}))))) + +;; ── Type constructors ───────────────────────────────────────────── +(ghm-test "tv" (hm-tv "a") (list :var "a")) +(ghm-test "int" (hm-int) (list :ctor "Int" (list))) +(ghm-test "arrow" (ctor-head (hm-arrow (hm-int) (hm-bool))) "->") +(ghm-test "arrow-args-len" (len (ctor-args (hm-arrow (hm-int) (hm-bool)))) 2) + +;; ── Schemes ─────────────────────────────────────────────────────── +(ghm-test "scheme-vars" (hm-scheme-vars (hm-scheme (list "a") (hm-tv "a"))) (list "a")) +(ghm-test "monotype-vars" (hm-scheme-vars (hm-monotype (hm-int))) (list)) +(ghm-test "scheme?-yes" (hm-scheme? (hm-monotype (hm-int))) true) +(ghm-test "scheme?-no" (hm-scheme? (hm-int)) false) + +;; ── Fresh tyvars ────────────────────────────────────────────────── +(ghm-test "fresh-1" + (let ((c (list 0))) (var-name (hm-fresh-tv c))) "t1") +(ghm-test "fresh-bumps" + (let ((c (list 5))) (begin (hm-fresh-tv c) (first c))) 6) + +;; ── Free type variables ────────────────────────────────────────── +(ghm-test "ftv-int" (hm-ftv (hm-int)) (list)) +(ghm-test "ftv-tv" (hm-ftv (hm-tv "a")) (list "a")) +(ghm-test "ftv-arrow" + (len (hm-ftv (hm-arrow (hm-tv "a") (hm-arrow (hm-tv "b") (hm-tv "a"))))) 2) +(ghm-test "ftv-scheme-quantified" + (hm-ftv-scheme (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "b")))) (list "b")) +(ghm-test "ftv-env" + (let ((env (assoc {} "f" (hm-monotype (hm-arrow (hm-tv "x") (hm-tv "y")))))) + (len (hm-ftv-env env))) 2) + +;; ── Substitution / apply / compose ─────────────────────────────── +(ghm-test "apply-tv" + (hm-apply (assoc {} "a" (hm-int)) (hm-tv "a")) (hm-int)) +(ghm-test "apply-arrow" + (ctor-head + (hm-apply (assoc {} "a" (hm-int)) + (hm-arrow (hm-tv "a") (hm-tv "b")))) "->") +(ghm-test "compose-1-then-2" + (var-name + (hm-apply + (hm-compose (assoc {} "b" (hm-tv "c")) (assoc {} "a" (hm-tv "b"))) + (hm-tv "a"))) "c") + +;; ── Generalize / Instantiate ───────────────────────────────────── +;; forall a. a -> a instantiated twice yields fresh vars each time +(ghm-test "generalize-id" + (len (hm-scheme-vars (hm-generalize (hm-arrow (hm-tv "a") (hm-tv "a")) {}))) 1) + +(ghm-test "generalize-skips-env" + ;; ftv(t)={a,b}, ftv(env)={a}, qs={b} + (let ((env (assoc {} "x" (hm-monotype (hm-tv "a"))))) + (len (hm-scheme-vars + (hm-generalize (hm-arrow (hm-tv "a") (hm-tv "b")) env)))) 1) + +(ghm-test "instantiate-fresh" + (let ((s (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "a")))) + (c (list 0))) + (let ((t1 (hm-instantiate s c)) (t2 (hm-instantiate s c))) + (not (= (var-name (first (ctor-args t1))) + (var-name (first (ctor-args t2))))))) + true) + +;; ── Inference (literal only) ───────────────────────────────────── +(ghm-test "infer-int" + (ctor-head (get (hm-infer-literal (ast-literal 42)) :type)) "Int") +(ghm-test "infer-string" + (ctor-head (get (hm-infer-literal (ast-literal "hi")) :type)) "String") +(ghm-test "infer-bool" + (ctor-head (get (hm-infer-literal (ast-literal true)) :type)) "Bool") + +(define ghm-tests-run! + (fn () + {:passed ghm-test-pass + :failed ghm-test-fail + :total (+ ghm-test-pass ghm-test-fail)})) diff --git a/lib/guest/tests/layout.sx b/lib/guest/tests/layout.sx new file mode 100644 index 00000000..0a922b2e --- /dev/null +++ b/lib/guest/tests/layout.sx @@ -0,0 +1,180 @@ +;; lib/guest/tests/layout.sx — synthetic Python-ish off-side fixture. +;; +;; Exercises lib/guest/layout.sx with a config different from Haskell's +;; (no module-prelude, layout opens via trailing `:` not via reserved +;; keyword) to prove the kit isn't Haskell-shaped. + +(define glayout-test-pass 0) +(define glayout-test-fail 0) +(define glayout-test-fails (list)) + +(define + glayout-test + (fn (name actual expected) + (if (= actual expected) + (set! glayout-test-pass (+ glayout-test-pass 1)) + (begin + (set! glayout-test-fail (+ glayout-test-fail 1)) + (append! glayout-test-fails {:name name :expected expected :actual actual}))))) + +;; Convenience: build a token from {type value line col}. +(define + glayout-tok + (fn (ty val line col) + {:type ty :value val :line line :col col})) + +;; Project a token list to ((type value) ...) for compact comparison. +(define + glayout-shape + (fn (toks) + (map (fn (t) (list (get t :type) (get t :value))) toks))) + +;; ── Haskell-flavour: keyword opens block ───────────────────────── +(define + glayout-haskell-cfg + {:open-keywords (list "let" "where" "do" "of") + :open-trailing-fn nil + :open-token {:type "vlbrace" :value "{"} + :close-token {:type "vrbrace" :value "}"} + :sep-token {:type "vsemi" :value ";"} + :module-prelude? false + :explicit-open? (fn (tok) (= (get tok :type) "lbrace"))}) + +;; do +;; a +;; b +;; c ← outside the do-block +(glayout-test "haskell-do-block" + (glayout-shape + (layout-pass + glayout-haskell-cfg + (list (glayout-tok "reserved" "do" 1 1) + (glayout-tok "ident" "a" 2 3) + (glayout-tok "ident" "b" 3 3) + (glayout-tok "ident" "c" 4 1)))) + (list (list "reserved" "do") + (list "vlbrace" "{") + (list "ident" "a") + (list "vsemi" ";") + (list "ident" "b") + (list "vrbrace" "}") + (list "ident" "c"))) + +;; Explicit `{` after `do` suppresses virtual layout. +(glayout-test "haskell-explicit-brace" + (glayout-shape + (layout-pass + glayout-haskell-cfg + (list (glayout-tok "reserved" "do" 1 1) + (glayout-tok "lbrace" "{" 1 4) + (glayout-tok "ident" "a" 1 6) + (glayout-tok "rbrace" "}" 1 8)))) + (list (list "reserved" "do") + (list "lbrace" "{") + (list "ident" "a") + (list "rbrace" "}"))) + +;; Single-statement do-block on the same line. +(glayout-test "haskell-do-inline" + (glayout-shape + (layout-pass + glayout-haskell-cfg + (list (glayout-tok "reserved" "do" 1 1) + (glayout-tok "ident" "a" 1 4)))) + (list (list "reserved" "do") + (list "vlbrace" "{") + (list "ident" "a") + (list "vrbrace" "}"))) + +;; Module-prelude: wrap whole input in implicit layout block at first +;; tok's column. +(glayout-test "haskell-module-prelude" + (glayout-shape + (layout-pass + (assoc glayout-haskell-cfg :module-prelude? true) + (list (glayout-tok "ident" "x" 1 1) + (glayout-tok "ident" "y" 2 1) + (glayout-tok "ident" "z" 3 1)))) + (list (list "vlbrace" "{") + (list "ident" "x") + (list "vsemi" ";") + (list "ident" "y") + (list "vsemi" ";") + (list "ident" "z") + (list "vrbrace" "}"))) + +;; ── Python-flavour: trailing `:` opens block ───────────────────── +(define + glayout-python-cfg + {:open-keywords (list) + :open-trailing-fn (fn (tok) (and (= (get tok :type) "punct") + (= (get tok :value) ":"))) + :open-token {:type "indent" :value "INDENT"} + :close-token {:type "dedent" :value "DEDENT"} + :sep-token {:type "newline" :value "NEWLINE"} + :module-prelude? false + :explicit-open? nil}) + +;; if x: +;; a +;; b +;; c +(glayout-test "python-if-block" + (glayout-shape + (layout-pass + glayout-python-cfg + (list (glayout-tok "reserved" "if" 1 1) + (glayout-tok "ident" "x" 1 4) + (glayout-tok "punct" ":" 1 5) + (glayout-tok "ident" "a" 2 5) + (glayout-tok "ident" "b" 3 5) + (glayout-tok "ident" "c" 4 1)))) + (list (list "reserved" "if") + (list "ident" "x") + (list "punct" ":") + (list "indent" "INDENT") + (list "ident" "a") + (list "newline" "NEWLINE") + (list "ident" "b") + (list "dedent" "DEDENT") + (list "ident" "c"))) + +;; Nested Python-style blocks. +;; def f(): +;; if x: +;; a +;; b +(glayout-test "python-nested" + (glayout-shape + (layout-pass + glayout-python-cfg + (list (glayout-tok "reserved" "def" 1 1) + (glayout-tok "ident" "f" 1 5) + (glayout-tok "punct" "(" 1 6) + (glayout-tok "punct" ")" 1 7) + (glayout-tok "punct" ":" 1 8) + (glayout-tok "reserved" "if" 2 5) + (glayout-tok "ident" "x" 2 8) + (glayout-tok "punct" ":" 2 9) + (glayout-tok "ident" "a" 3 9) + (glayout-tok "ident" "b" 4 5)))) + (list (list "reserved" "def") + (list "ident" "f") + (list "punct" "(") + (list "punct" ")") + (list "punct" ":") + (list "indent" "INDENT") + (list "reserved" "if") + (list "ident" "x") + (list "punct" ":") + (list "indent" "INDENT") + (list "ident" "a") + (list "dedent" "DEDENT") + (list "ident" "b") + (list "dedent" "DEDENT"))) + +(define glayout-tests-run! + (fn () + {:passed glayout-test-pass + :failed glayout-test-fail + :total (+ glayout-test-pass glayout-test-fail)})) diff --git a/lib/guest/tests/match.sx b/lib/guest/tests/match.sx new file mode 100644 index 00000000..25eb3a7b --- /dev/null +++ b/lib/guest/tests/match.sx @@ -0,0 +1,108 @@ +;; lib/guest/tests/match.sx — exercises lib/guest/match.sx. + +(define gmatch-test-pass 0) +(define gmatch-test-fail 0) +(define gmatch-test-fails (list)) + +(define + gmatch-test + (fn (name actual expected) + (if (= actual expected) + (set! gmatch-test-pass (+ gmatch-test-pass 1)) + (begin + (set! gmatch-test-fail (+ gmatch-test-fail 1)) + (append! gmatch-test-fails {:name name :expected expected :actual actual}))))) + +;; ── walk / extend / occurs ──────────────────────────────────────── +(gmatch-test "walk-direct" + (walk (mk-var "x") (extend "x" 5 (empty-subst))) 5) + +(gmatch-test "walk-chain" + (walk (mk-var "a") (extend "a" (mk-var "b") (extend "b" 7 (empty-subst)))) 7) + +(gmatch-test "walk-no-binding" + (let ((v (mk-var "u"))) (= (walk v (empty-subst)) v)) true) + +(gmatch-test "walk*-recursive" + (walk* (mk-ctor "Just" (list (mk-var "x"))) (extend "x" 9 (empty-subst))) + (mk-ctor "Just" (list 9))) + +(gmatch-test "occurs-direct" + (occurs? "x" (mk-var "x") (empty-subst)) true) + +(gmatch-test "occurs-nested" + (occurs? "x" (mk-ctor "f" (list (mk-var "x"))) (empty-subst)) true) + +(gmatch-test "occurs-not" + (occurs? "x" (mk-var "y") (empty-subst)) false) + +;; ── unify (symmetric) ───────────────────────────────────────────── +(gmatch-test "unify-equal-literals" + (len (unify 5 5 (empty-subst))) 0) + +(gmatch-test "unify-different-literals" + (unify 5 6 (empty-subst)) nil) + +(gmatch-test "unify-var-literal" + (get (unify (mk-var "x") 5 (empty-subst)) "x") 5) + +(gmatch-test "unify-literal-var" + (get (unify 5 (mk-var "x") (empty-subst)) "x") 5) + +(gmatch-test "unify-same-var" + (len (unify (mk-var "x") (mk-var "x") (empty-subst))) 0) + +(gmatch-test "unify-two-vars" + (let ((s (unify (mk-var "x") (mk-var "y") (empty-subst)))) + (or (= (get s "x") (mk-var "y")) (= (get s "y") (mk-var "x")))) true) + +(gmatch-test "unify-ctor-equal" + (len (unify (mk-ctor "f" (list 1 2)) (mk-ctor "f" (list 1 2)) (empty-subst))) 0) + +(gmatch-test "unify-ctor-with-var" + (get (unify (mk-ctor "Just" (list (mk-var "x"))) (mk-ctor "Just" (list 7)) (empty-subst)) "x") 7) + +(gmatch-test "unify-ctor-head-mismatch" + (unify (mk-ctor "Just" (list 1)) (mk-ctor "Nothing" (list)) (empty-subst)) nil) + +(gmatch-test "unify-ctor-arity-mismatch" + (unify (mk-ctor "f" (list 1 2)) (mk-ctor "f" (list 1)) (empty-subst)) nil) + +(gmatch-test "unify-occurs-check" + (unify (mk-var "x") (mk-ctor "f" (list (mk-var "x"))) (empty-subst)) nil) + +(gmatch-test "unify-transitive-vars" + (let ((s (unify (mk-var "x") (mk-var "y") (empty-subst)))) + (let ((s2 (unify (mk-var "y") 42 s))) + (walk (mk-var "x") s2))) 42) + +;; ── match-pat (asymmetric) ──────────────────────────────────────── +(gmatch-test "match-var-binds" + (get (match-pat (mk-var "x") 99 (empty-subst)) "x") 99) + +(gmatch-test "match-literal-equal" + (len (match-pat 5 5 (empty-subst))) 0) + +(gmatch-test "match-literal-mismatch" + (match-pat 5 6 (empty-subst)) nil) + +(gmatch-test "match-ctor-binds" + (get (match-pat (mk-ctor "Just" (list (mk-var "y"))) + (mk-ctor "Just" (list 11)) + (empty-subst)) "y") 11) + +(gmatch-test "match-ctor-head-mismatch" + (match-pat (mk-ctor "Just" (list (mk-var "y"))) + (mk-ctor "Nothing" (list)) + (empty-subst)) nil) + +(gmatch-test "match-ctor-arity-mismatch" + (match-pat (mk-ctor "f" (list (mk-var "x") (mk-var "y"))) + (mk-ctor "f" (list 1)) + (empty-subst)) nil) + +(define gmatch-tests-run! + (fn () + {:passed gmatch-test-pass + :failed gmatch-test-fail + :total (+ gmatch-test-pass gmatch-test-fail)})) diff --git a/lib/haskell/conformance.conf b/lib/haskell/conformance.conf new file mode 100644 index 00000000..f6a3f03e --- /dev/null +++ b/lib/haskell/conformance.conf @@ -0,0 +1,96 @@ +# Haskell-on-SX conformance config — sourced by lib/guest/conformance.sh. + +LANG_NAME=haskell +MODE=counters +COUNTERS_PASS=hk-test-pass +COUNTERS_FAIL=hk-test-fail +TIMEOUT_PER_SUITE=120 + +PRELOADS=( + lib/haskell/tokenizer.sx + lib/haskell/layout.sx + lib/haskell/parser.sx + lib/haskell/desugar.sx + lib/haskell/runtime.sx + lib/haskell/match.sx + lib/haskell/eval.sx + lib/haskell/map.sx + lib/haskell/set.sx + lib/haskell/testlib.sx +) + +SUITES=( + "fib:lib/haskell/tests/program-fib.sx" + "sieve:lib/haskell/tests/program-sieve.sx" + "quicksort:lib/haskell/tests/program-quicksort.sx" + "nqueens:lib/haskell/tests/program-nqueens.sx" + "calculator:lib/haskell/tests/program-calculator.sx" + "collatz:lib/haskell/tests/program-collatz.sx" + "palindrome:lib/haskell/tests/program-palindrome.sx" + "maybe:lib/haskell/tests/program-maybe.sx" + "fizzbuzz:lib/haskell/tests/program-fizzbuzz.sx" + "anagram:lib/haskell/tests/program-anagram.sx" + "roman:lib/haskell/tests/program-roman.sx" + "binary:lib/haskell/tests/program-binary.sx" + "either:lib/haskell/tests/program-either.sx" + "primes:lib/haskell/tests/program-primes.sx" + "zipwith:lib/haskell/tests/program-zipwith.sx" + "matrix:lib/haskell/tests/program-matrix.sx" + "wordcount:lib/haskell/tests/program-wordcount.sx" + "powers:lib/haskell/tests/program-powers.sx" + "caesar:lib/haskell/tests/program-caesar.sx" + "runlength-str:lib/haskell/tests/program-runlength-str.sx" + "showadt:lib/haskell/tests/program-showadt.sx" + "showio:lib/haskell/tests/program-showio.sx" + "partial:lib/haskell/tests/program-partial.sx" + "statistics:lib/haskell/tests/program-statistics.sx" + "newton:lib/haskell/tests/program-newton.sx" + "wordfreq:lib/haskell/tests/program-wordfreq.sx" + "mapgraph:lib/haskell/tests/program-mapgraph.sx" + "uniquewords:lib/haskell/tests/program-uniquewords.sx" + "setops:lib/haskell/tests/program-setops.sx" + "shapes:lib/haskell/tests/program-shapes.sx" + "person:lib/haskell/tests/program-person.sx" + "config:lib/haskell/tests/program-config.sx" + "counter:lib/haskell/tests/program-counter.sx" + "accumulate:lib/haskell/tests/program-accumulate.sx" + "safediv:lib/haskell/tests/program-safediv.sx" + "trycatch:lib/haskell/tests/program-trycatch.sx" +) + +emit_scoreboard_json() { + local n=${#GC_NAMES[@]} i sep date_only + date_only=$(date '+%Y-%m-%d') + printf '{\n' + printf ' "date": "%s",\n' "$date_only" + printf ' "total_pass": %d,\n' "$GC_TOTAL_PASS" + printf ' "total_fail": %d,\n' "$GC_TOTAL_FAIL" + printf ' "programs": {\n' + for ((i=0; i "$TMPFILE" <&1 || true) - rm -f "$TMPFILE" - - local LINE - 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/\)$//' || true) - fi - if [ -z "$LINE" ]; then - echo "0 1" - else - local P F - P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/' || echo "0") - F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/' || echo "1") - echo "$P $F" - fi -} - -for prog in "${PROGRAMS[@]}"; do - RESULT=$(run_suite "$prog") - P=$(echo "$RESULT" | cut -d' ' -f1) - F=$(echo "$RESULT" | cut -d' ' -f2) - PASS_COUNTS+=("$P") - FAIL_COUNTS+=("$F") - T=$((P + F)) - if [ "$F" -eq 0 ]; then - printf '✓ %-14s %d/%d\n' "${prog}.hs" "$P" "$T" - else - printf '✗ %-14s %d/%d\n' "${prog}.hs" "$P" "$T" - fi -done - -TOTAL_PASS=0 -TOTAL_FAIL=0 -PROG_PASS=0 -for i in "${!PROGRAMS[@]}"; do - TOTAL_PASS=$((TOTAL_PASS + PASS_COUNTS[i])) - TOTAL_FAIL=$((TOTAL_FAIL + FAIL_COUNTS[i])) - [ "${FAIL_COUNTS[$i]}" -eq 0 ] && PROG_PASS=$((PROG_PASS + 1)) -done -PROG_TOTAL=${#PROGRAMS[@]} - -echo "" -echo "Classic programs: ${TOTAL_PASS}/$((TOTAL_PASS + TOTAL_FAIL)) tests | ${PROG_PASS}/${PROG_TOTAL} programs passing" - -if [[ "${1:-}" == "--check" ]]; then - [ $TOTAL_FAIL -eq 0 ] - exit $? -fi - -DATE=$(date '+%Y-%m-%d') - -# scoreboard.json -{ - printf '{\n' - printf ' "date": "%s",\n' "$DATE" - printf ' "total_pass": %d,\n' "$TOTAL_PASS" - printf ' "total_fail": %d,\n' "$TOTAL_FAIL" - printf ' "programs": {\n' - last=$((${#PROGRAMS[@]} - 1)) - for i in "${!PROGRAMS[@]}"; do - prog="${PROGRAMS[$i]}" - if [ $i -lt $last ]; then - printf ' "%s": {"pass": %d, "fail": %d},\n' "$prog" "${PASS_COUNTS[$i]}" "${FAIL_COUNTS[$i]}" - else - printf ' "%s": {"pass": %d, "fail": %d}\n' "$prog" "${PASS_COUNTS[$i]}" "${FAIL_COUNTS[$i]}" - fi - done - printf ' }\n' - printf '}\n' -} > lib/haskell/scoreboard.json - -# scoreboard.md -{ - printf '# Haskell-on-SX Scoreboard\n\n' - printf 'Updated %s · Phase 6 (prelude extras + 18 programs)\n\n' "$DATE" - printf '| Program | Tests | Status |\n' - printf '|---------|-------|--------|\n' - for i in "${!PROGRAMS[@]}"; do - prog="${PROGRAMS[$i]}" - P=${PASS_COUNTS[$i]} - F=${FAIL_COUNTS[$i]} - T=$((P + F)) - [ "$F" -eq 0 ] && STATUS="✓" || STATUS="✗" - printf '| %s | %d/%d | %s |\n' "${prog}.hs" "$P" "$T" "$STATUS" - done - printf '| **Total** | **%d/%d** | **%d/%d programs** |\n' \ - "$TOTAL_PASS" "$((TOTAL_PASS + TOTAL_FAIL))" "$PROG_PASS" "$PROG_TOTAL" -} > lib/haskell/scoreboard.md - -echo "Wrote lib/haskell/scoreboard.json and lib/haskell/scoreboard.md" -[ $TOTAL_FAIL -eq 0 ] +# Thin wrapper — see lib/guest/conformance.sh and lib/haskell/conformance.conf. +exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@" diff --git a/lib/hyperscript/compiler.sx b/lib/hyperscript/compiler.sx index 1e22f874..f3c227da 100644 --- a/lib/hyperscript/compiler.sx +++ b/lib/hyperscript/compiler.sx @@ -7,6 +7,22 @@ ;; (hs-to-sx (hs-compile "on click add .active to me")) ;; → (hs-on me "click" (fn (event) (dom-add-class me "active"))) +;; ── Compiler plugin registries ──────────────────────────────────── +;; Plugins call (hs-register-command! "head" compile-fn) and +;; (hs-register-converter! "TypeName" convert-fn) at load time. Both +;; compile-fn and convert-fn receive a ctx dict (built per call inside +;; hs-to-sx) exposing :hs-to-sx for recursion plus the AST node fields +;; the dispatch needs. Compile-fn returns an SX expression. +(begin + (define _hs-command-registry {}) + (define _hs-converter-registry {}) + (define + hs-register-command! + (fn (name compile-fn) (dict-set! _hs-command-registry name compile-fn))) + (define + hs-register-converter! + (fn (name convert-fn) (dict-set! _hs-converter-registry name convert-fn)))) + (define hs-to-sx (let @@ -32,7 +48,7 @@ (let ((th (first target))) (cond - ((= th dot-sym) + ((or (= th dot-sym) (= th (make-symbol "poss"))) (let ((base-ast (nth target 1)) (prop (nth target 2))) (cond @@ -48,6 +64,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)) @@ -68,16 +93,61 @@ (list (quote hs-query-all) (nth inner 1))))) (true (list - (quote dom-set-prop) - (hs-to-sx base-ast) - prop - value))))) + (quote let) + (list + (list + (quote __hs-obj) + (if + (or + (symbol? base-ast) + (and + (list? base-ast) + (= (str (first base-ast)) "ref"))) + (let + ((sel (if (symbol? base-ast) (str base-ast) (nth base-ast 1)))) + (list + (quote do) + (list + (quote host-set!) + (list (quote host-global) "window") + "_hs_last_query_sel" + sel) + (hs-to-sx base-ast))) + (hs-to-sx base-ast)))) + (list + (quote do) + (list (quote hs-null-raise!) (quote __hs-obj)) + (list + (quote when) + (list + (quote not) + (list (quote nil?) (quote __hs-obj))) + (list + (quote dom-set-prop) + (quote __hs-obj) + prop + value)))))))) ((= th (quote attr)) - (list - (quote hs-set-attr!) - (hs-to-sx (nth target 2)) - (nth target 1) - value)) + (let + ((base-ast (nth target 2))) + (if + (and (list? base-ast) (= (str (first base-ast)) "ref")) + (list + (quote do) + (list + (quote set!) + (quote _hs-last-query-sel) + (nth base-ast 1)) + (list + (quote hs-set-attr!) + (hs-to-sx base-ast) + (nth target 1) + value)) + (list + (quote hs-set-attr!) + (hs-to-sx base-ast) + (nth target 1) + value)))) ((= th (quote style)) (list (quote dom-set-style) @@ -145,7 +215,16 @@ (hs-to-sx obj-ast) (nth prop-ast 1) value) - (list (quote set!) (hs-to-sx target) value)))))) + (if + (and + (list? prop-ast) + (= (first prop-ast) (quote style))) + (list + (quote dom-set-style) + (hs-to-sx obj-ast) + (nth prop-ast 1) + value) + (list (quote set!) (hs-to-sx target) value))))))) (true (list (quote set!) (hs-to-sx target) value))))))) (define emit-on @@ -164,13 +243,17 @@ every? catch-info finally-info - having-info) + having-info + of-filter-info + count-filter-info + elsewhere? + or-sources) (cond ((<= (len items) 1) (let ((body (if (> (len items) 0) (first items) nil))) (let - ((target (if source (hs-to-sx source) (quote me)))) + ((target (cond (elsewhere? (list (quote dom-body))) (source (hs-to-sx source)) (true (quote me))))) (let ((event-refs (if (and (list? body) (= (first body) (quote do))) (filter (fn (x) (and (list? x) (= (first x) (quote ref)))) (rest body)) (list)))) (let @@ -178,30 +261,71 @@ (let ((raw-compiled (hs-to-sx stripped-body))) (let - ((compiled-body (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote host-get) (list (quote host-get) (quote event) "detail") name)))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled))) + ((compiled-body (let ((base (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote let) (list (list (quote _det) (list (quote host-get) (quote event) "detail"))) (list (quote if) (list (quote and) (quote _det) (list (quote not) (list (quote nil?) (list (quote host-get) (quote _det) name)))) (list (quote host-get) (quote _det) name) (list (quote host-get) (quote event) name)))))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled))) (if elsewhere? (list (quote when) (list (quote not) (list (quote host-call) (quote me) "contains" (list (quote host-get) (quote event) "target"))) base) base)))) (let - ((wrapped-body (if catch-info (let ((var (make-symbol (nth catch-info 0))) (catch-body (hs-to-sx (nth catch-info 1)))) (if finally-info (list (quote do) (list (quote guard) (list var (list true catch-body)) compiled-body) (hs-to-sx finally-info)) (list (quote guard) (list var (list true catch-body)) compiled-body))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body)))) + ((wrapped-body (if catch-info (let ((var (make-symbol (nth catch-info 0))) (catch-body (hs-to-sx (nth catch-info 1)))) (if finally-info (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (hs-to-sx finally-info) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))) (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body)))) (let - ((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body))))) + ((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler))))) (let ((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler)))) - (if - (= event-name "intersection") - (list - (quote do) - on-call + (cond + ((= event-name "mutation") (list - (quote hs-on-intersection-attach!) - target - (if - having-info - (get having-info "margin") - nil) - (if - having-info - (get having-info "threshold") - nil))) - on-call))))))))))) + (quote do) + on-call + (list + (quote hs-on-mutation-attach!) + target + (if + of-filter-info + (get of-filter-info "type") + "any") + (if + of-filter-info + (let + ((a (get of-filter-info "attrs"))) + (if + a + (cons (quote list) a) + nil)) + nil)))) + ((= event-name "intersection") + (list + (quote do) + on-call + (list + (quote + hs-on-intersection-attach!) + target + (if + having-info + (get having-info "margin") + nil) + (if + having-info + (get having-info "threshold") + nil)))) + (true + (if + or-sources + (cons + (quote do) + (cons + on-call + (map + (fn + (pair) + (list + (quote hs-on) + (if + (nth pair 1) + (hs-to-sx + (nth pair 1)) + (quote me)) + (first pair) + handler)) + or-sources))) + on-call))))))))))))) ((= (first items) :from) (scan-on (rest (rest items)) @@ -210,7 +334,11 @@ every? catch-info finally-info - having-info)) + having-info + of-filter-info + count-filter-info + elsewhere? + or-sources)) ((= (first items) :filter) (scan-on (rest (rest items)) @@ -219,7 +347,11 @@ every? catch-info finally-info - having-info)) + having-info + of-filter-info + count-filter-info + elsewhere? + or-sources)) ((= (first items) :every) (scan-on (rest (rest items)) @@ -228,7 +360,11 @@ true catch-info finally-info - having-info)) + having-info + of-filter-info + count-filter-info + elsewhere? + or-sources)) ((= (first items) :catch) (scan-on (rest (rest items)) @@ -237,7 +373,11 @@ every? (nth items 1) finally-info - having-info)) + having-info + of-filter-info + count-filter-info + elsewhere? + or-sources)) ((= (first items) :finally) (scan-on (rest (rest items)) @@ -246,7 +386,11 @@ every? catch-info (nth items 1) - having-info)) + having-info + of-filter-info + count-filter-info + elsewhere? + or-sources)) ((= (first items) :having) (scan-on (rest (rest items)) @@ -255,6 +399,62 @@ every? catch-info finally-info + (nth items 1) + of-filter-info + count-filter-info + elsewhere? + or-sources)) + ((= (first items) :of-filter) + (scan-on + (rest (rest items)) + source + filter + every? + catch-info + finally-info + having-info + (nth items 1) + count-filter-info + elsewhere? + or-sources)) + ((= (first items) :count-filter) + (scan-on + (rest (rest items)) + source + filter + every? + catch-info + finally-info + having-info + of-filter-info + (nth items 1) + elsewhere? + or-sources)) + ((= (first items) :elsewhere) + (scan-on + (rest (rest items)) + source + filter + every? + catch-info + finally-info + having-info + of-filter-info + count-filter-info + (nth items 1) + or-sources)) + ((= (first items) :or-sources) + (scan-on + (rest (rest items)) + source + filter + every? + catch-info + finally-info + having-info + of-filter-info + count-filter-info + elsewhere? (nth items 1))) (true (scan-on @@ -264,8 +464,12 @@ every? catch-info finally-info - having-info))))) - (scan-on (rest parts) nil nil false nil nil nil))))) + having-info + of-filter-info + count-filter-info + elsewhere? + or-sources))))) + (scan-on (rest parts) nil nil false nil nil nil nil nil false nil))))) (define emit-send (fn @@ -275,13 +479,13 @@ (cond ((and (= (len ast) 4) (list? (nth ast 2)) (= (first (nth ast 2)) (quote dict))) (list - (quote dom-dispatch) + (quote hs-dispatch!) (hs-to-sx (nth ast 3)) name (hs-to-sx (nth ast 2)))) ((= (len ast) 3) (list - (quote dom-dispatch) + (quote hs-dispatch!) (hs-to-sx (nth ast 2)) name (list (quote dict) "sender" (quote me)))) @@ -331,12 +535,20 @@ (quote hs-repeat-times) (hs-to-sx mode) (list (quote fn) (list) body))))))) + (define + hs-reserved-var? + (fn (name) (or (= name "meta") (= name "event") (= name "result")))) (define emit-for (fn (ast) (let ((var-name (nth ast 1)) + (safe-param + (if + (hs-reserved-var? var-name) + (str "_hs_lv_" var-name) + var-name)) (raw-coll-ast (nth ast 2)) (where-cond (if @@ -371,12 +583,12 @@ (quote map-indexed) (list (quote fn) - (list (make-symbol (nth ast 5)) (make-symbol var-name)) + (list (make-symbol (nth ast 5)) (make-symbol safe-param)) body) collection) (list (quote hs-for-each) - (list (quote fn) (list (make-symbol var-name)) body) + (list (quote fn) (list (make-symbol safe-param)) body) collection))))) (define emit-wait-for @@ -485,24 +697,37 @@ (quote do) (list (quote dom-set-attr) el attr-name (quote __hs-new)) (list (quote set!) (quote it) (quote __hs-new)))))) - ((and (list? expr) (= (first expr) dot-sym)) + ((and (list? expr) (or (= (first expr) dot-sym) (= (first expr) (make-symbol "poss")))) (let ((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2))) (list (quote let) - (list - (list - (quote __hs-new) - (list - (quote +) - (list - (quote hs-to-number) - (list (quote host-get) obj prop)) - amount))) + (list (list (quote __hs-obj) obj)) (list (quote do) - (list (quote host-set!) obj prop (quote __hs-new)) - (list (quote set!) (quote it) (quote __hs-new)))))) + (list (quote hs-null-raise!) (quote __hs-obj)) + (list + (quote when) + (list (quote not) (list (quote nil?) (quote __hs-obj))) + (list + (quote let) + (list + (list + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote host-get) (quote __hs-obj) prop)) + amount))) + (list + (quote do) + (list + (quote host-set!) + (quote __hs-obj) + prop + (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new))))))))) ((and (list? expr) (= (first expr) (quote style))) (let ((el (if tgt-override (hs-to-sx tgt-override) (quote me))) @@ -601,24 +826,37 @@ (quote do) (list (quote dom-set-attr) el attr-name (quote __hs-new)) (list (quote set!) (quote it) (quote __hs-new)))))) - ((and (list? expr) (= (first expr) dot-sym)) + ((and (list? expr) (or (= (first expr) dot-sym) (= (first expr) (make-symbol "poss")))) (let ((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2))) (list (quote let) - (list - (list - (quote __hs-new) - (list - (quote -) - (list - (quote hs-to-number) - (list (quote host-get) obj prop)) - amount))) + (list (list (quote __hs-obj) obj)) (list (quote do) - (list (quote host-set!) obj prop (quote __hs-new)) - (list (quote set!) (quote it) (quote __hs-new)))))) + (list (quote hs-null-raise!) (quote __hs-obj)) + (list + (quote when) + (list (quote not) (list (quote nil?) (quote __hs-obj))) + (list + (quote let) + (list + (list + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote host-get) (quote __hs-obj) prop)) + amount))) + (list + (quote do) + (list + (quote host-set!) + (quote __hs-obj) + prop + (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new))))))))) ((and (list? expr) (= (first expr) (quote style))) (let ((el (if tgt-override (hs-to-sx tgt-override) (quote me))) @@ -704,1385 +942,1776 @@ (make-symbol name) (list (quote fn) - (cons (quote me) (map make-symbol params)) - (cons (quote do) (map hs-to-sx body))))))) + (cons + (quote me) + (map + (fn + (p) + (if (list? p) (make-symbol (nth p 1)) (make-symbol p))) + params)) + (list + (quote let) + (list (list (quote beingTold) (quote me))) + (cons (quote do) (map hs-to-sx body)))))))) (fn (ast) - (cond - ((nil? ast) nil) - ((number? ast) ast) - ((string? ast) ast) - ((boolean? ast) ast) - ((and (symbol? ast) (= (str ast) "sender")) - (list (quote hs-sender) (quote event))) - ((not (list? ast)) ast) - (true - (let - ((head (first ast))) - (cond - ((= head (quote __bind-from-detail__)) - (let - ((name-str (nth ast 1))) - (list - (quote define) - (make-symbol name-str) - (list - (quote host-get) - (list (quote host-get) (quote it) "detail") - name-str)))) - ((= head (quote sender)) - (list (quote hs-sender) (quote event))) - ((= head (quote null-literal)) nil) - ((= head (quote not)) - (list (quote not) (hs-to-sx (nth ast 1)))) - ((or (= head (quote and)) (= head (quote or)) (= head (quote >=)) (= head (quote <=)) (= head (quote >)) (= head (quote <))) - (cons head (map hs-to-sx (rest ast)))) - ((= head (quote object-literal)) - (let - ((pairs (nth ast 1))) - (if - (= (len pairs) 0) - (list (quote dict)) - (cons - (quote hs-make-object) - (list - (cons - (quote list) - (map - (fn - (pair) - (list - (quote list) - (first pair) - (hs-to-sx (nth pair 1)))) - pairs))))))) - ((= head (quote template)) - (let - ((raw (nth ast 1))) - (let - ((parts (list)) (buf "") (i 0) (n (len raw))) - (define - tpl-flush - (fn - () - (when - (> (len buf) 0) - (set! parts (append parts (list buf))) - (set! buf "")))) - (define - tpl-read-id - (fn - (j) - (if - (and - (< j n) - (let - ((c (nth raw j))) - (or - (and (>= c "a") (<= c "z")) - (and (>= c "A") (<= c "Z")) - (and (>= c "0") (<= c "9")) - (= c "_") - (= c ".")))) - (tpl-read-id (+ j 1)) - j))) - (define - tpl-find-close - (fn - (j depth) - (if - (>= j n) - j - (if - (= (nth raw j) "}") - (if - (= depth 1) - j - (tpl-find-close (+ j 1) (- depth 1))) - (if - (= (nth raw j) "{") - (tpl-find-close (+ j 1) (+ depth 1)) - (tpl-find-close (+ j 1) depth)))))) - (define - tpl-collect - (fn - () - (when - (< i n) - (let - ((ch (nth raw i))) - (if - (and (= ch "$") (< (+ i 1) n)) - (if - (= (nth raw (+ i 1)) "{") - (let - ((start (+ i 2))) - (let - ((close (tpl-find-close start 1))) - (let - ((expr-src (slice raw start close))) - (do - (tpl-flush) - (set! - parts - (append - parts - (list - (hs-to-sx (hs-compile expr-src))))) - (set! i (+ close 1)) - (tpl-collect))))) - (let - ((start (+ i 1))) - (let - ((end (tpl-read-id start))) - (let - ((ident (slice raw start end))) - (do - (tpl-flush) - (set! - parts - (append - parts - (list - (hs-to-sx (hs-compile ident))))) - (set! i end) - (tpl-collect)))))) - (do - (set! buf (str buf ch)) - (set! i (+ i 1)) - (tpl-collect))))))) - (tpl-collect) - (tpl-flush) - (cons (quote str) parts)))) - ((= head (quote beep!)) - (list (quote hs-beep) (hs-to-sx (nth ast 1)))) - ((= head (quote array-index)) - (list - (quote hs-index) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote array-slice)) - (list - (quote hs-slice) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)) - (hs-to-sx (nth ast 3)))) - ((= head (quote pick-first)) - (list - (quote set!) - (quote it) - (list - (quote hs-pick-first) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2))))) - ((= head (quote pick-last)) - (list - (quote set!) - (quote it) - (list - (quote hs-pick-last) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2))))) - ((= head (quote pick-random)) - (list - (quote set!) - (quote it) - (list - (quote hs-pick-random) - (hs-to-sx (nth ast 1)) - (if (nil? (nth ast 2)) nil (hs-to-sx (nth ast 2)))))) - ((= head (quote pick-items)) - (list - (quote set!) - (quote it) - (list - (quote hs-pick-items) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)) - (hs-to-sx (nth ast 3))))) - ((= head (quote pick-match)) - (list - (quote set!) - (quote it) - (list - (quote hs-pick-match) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2))))) - ((= head (quote pick-matches)) - (list - (quote set!) - (quote it) - (list - (quote hs-pick-matches) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2))))) - ((= head (quote prop-is)) - (list - (quote hs-prop-is) - (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote coll-where)) - (list - (quote filter) - (list - (quote fn) - (list (quote it)) - (hs-to-sx (nth ast 2))) - (hs-to-sx (nth ast 1)))) - ((= head (quote coll-sorted)) - (list - (quote hs-sorted-by) - (hs-to-sx (nth ast 1)) - (list - (quote fn) - (list (quote it)) - (hs-to-sx (nth ast 2))))) - ((= head (quote coll-sorted-desc)) - (list - (quote hs-sorted-by-desc) - (hs-to-sx (nth ast 1)) - (list - (quote fn) - (list (quote it)) - (hs-to-sx (nth ast 2))))) - ((= head (quote coll-mapped)) - (list - (quote map) - (list - (quote fn) - (list (quote it)) - (hs-to-sx (nth ast 2))) - (hs-to-sx (nth ast 1)))) - ((= head (quote coll-split)) - (list - (quote hs-split-by) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote coll-joined)) - (list - (quote hs-joined-by) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote method-call)) - (let - ((dot-node (nth ast 1)) - (args (map hs-to-sx (nth ast 2)))) - (if + (let + ((ast (if (and (dict? ast) (get ast :hs-ast)) (get ast :children) ast))) + (cond + ((nil? ast) nil) + ((number? ast) ast) + ((string? ast) ast) + ((boolean? ast) ast) + ((and (symbol? ast) (= (str ast) "sender")) + (list (quote hs-sender) (quote event))) + ((not (list? ast)) ast) + (true + (let + ((head (first ast))) + (let + ((reg-cmd-fn (dict-get _hs-command-registry (str head))) + (reg-conv-fn (and - (list? dot-node) - (= (first dot-node) (make-symbol "."))) - (let - ((obj (hs-to-sx (nth dot-node 1))) - (method (nth dot-node 2))) - (cons - (quote hs-method-call) - (cons obj (cons method args)))) - (cons - (quote hs-method-call) - (cons (hs-to-sx dot-node) args))))) - ((= head (quote string-postfix)) - (list (quote str) (hs-to-sx (nth ast 1)) (nth ast 2))) - ((= head (quote block-literal)) - (let - ((params (map make-symbol (nth ast 1))) - (body (hs-to-sx (nth ast 2)))) - (if - (= (len params) 0) - body - (list (quote fn) params body)))) - ((= head (quote me)) (quote me)) - ((= head (quote it)) (quote it)) - ((= head (quote event)) (quote event)) - ((= head dot-sym) - (let - ((target (let ((t (hs-to-sx (nth ast 1)))) (if (and (symbol? t) (or (= (str t) "window") (= (str t) "document") (= (str t) "navigator") (= (str t) "location") (= (str t) "history") (= (str t) "screen") (= (str t) "localStorage") (= (str t) "sessionStorage") (= (str t) "console"))) (list (quote host-global) (str t)) t))) - (prop (nth ast 2))) - (cond - ((= prop "first") (list (quote hs-first) target)) - ((= prop "last") (list (quote hs-last) target)) - (true (list (quote host-get) target prop))))) - ((= head (quote ref)) - (if - (= (nth ast 1) "selection") - (list (quote hs-get-selection)) - (make-symbol (nth ast 1)))) - ((= head (quote query)) - (list (quote hs-query-first) (nth ast 1))) - ((= head (quote query-scoped)) - (list - (quote hs-query-all-in) - (nth ast 1) - (hs-to-sx (nth ast 2)))) - ((= head (quote attr)) - (list - (quote dom-get-attr) - (hs-to-sx (nth ast 2)) - (nth ast 1))) - ((= head (quote style)) - (list - (quote dom-get-style) - (hs-to-sx (nth ast 2)) - (nth ast 1))) - ((= head (quote dom-ref)) - (list - (quote hs-dom-get) - (hs-to-sx (nth ast 2)) - (nth ast 1))) - ((= head (quote has-class?)) - (list - (quote dom-has-class?) - (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote local)) - (list (quote hs-scoped-get) (quote me) (nth ast 1))) - ((= head (quote array)) - (cons (quote list) (map hs-to-sx (rest ast)))) - ((= head (quote not)) - (list (quote not) (hs-to-sx (nth ast 1)))) - ((= head (quote no)) - (list (quote hs-falsy?) (hs-to-sx (nth ast 1)))) - ((= head (quote and)) - (list - (quote and) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote or)) - (list - (quote or) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote =)) - (list - (quote =) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote +)) - (list - (quote hs-add) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote -)) - (list - (quote -) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote *)) - (list - (quote *) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote /)) - (list - (quote /) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head pct-sym) - (if - (nil? (nth ast 2)) - (list (quote str) (hs-to-sx (nth ast 1)) "%") - (list - (quote modulo) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2))))) - ((= head (quote empty?)) - (list (quote hs-empty?) (hs-to-sx (nth ast 1)))) - ((= head (quote exists?)) - (list - (quote not) - (list (quote nil?) (hs-to-sx (nth ast 1))))) - ((= head (quote matches?)) - (let - ((left (nth ast 1)) (right (nth ast 2))) - (if - (and (list? right) (= (first right) (quote query))) - (list (quote hs-matches?) (hs-to-sx left) (nth right 1)) - (list - (quote hs-matches?) - (hs-to-sx left) - (hs-to-sx right))))) - ((= head (quote matches-ignore-case?)) - (list - (quote hs-matches-ignore-case?) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote starts-with-ic?)) - (list - (quote hs-starts-with-ic?) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote ends-with-ic?)) - (list - (quote hs-ends-with-ic?) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote starts-with?)) - (list - (quote hs-starts-with?) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote ends-with?)) - (list - (quote hs-ends-with?) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote precedes?)) - (list - (quote hs-precedes?) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote follows?)) - (list - (quote hs-follows?) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote contains?)) - (list - (quote hs-contains?) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote contains-ignore-case?)) - (list - (quote hs-contains-ignore-case?) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote as)) - (list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2))) - ((= head (quote in?)) - (list - (quote hs-contains?) - (hs-to-sx (nth ast 2)) - (hs-to-sx (nth ast 1)))) - ((= head (quote of)) - (let - ((prop (hs-to-sx (nth ast 1))) - (target (hs-to-sx (nth ast 2)))) - (cond - ((= prop (quote first)) (list (quote first) target)) - ((= prop (quote last)) (list (quote last) target)) - (true (list (quote host-get) target prop))))) - ((= head "!=") - (list - (quote not) - (list - (quote =) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2))))) - ((= head "<") - (list - (quote <) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head ">") - (list - (quote >) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head "<=") - (list - (quote <=) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head ">=") - (list - (quote >=) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote closest)) - (list - (quote dom-closest) - (hs-to-sx (nth ast 2)) - (nth ast 1))) - ((= head (quote closest-parent)) - (list - (quote dom-closest) - (list - (quote host-get) - (hs-to-sx (nth ast 2)) - "parentElement") - (nth ast 1))) - ((= head (quote next)) - (list (quote hs-next) (hs-to-sx (nth ast 2)) (nth ast 1))) - ((= head (quote previous)) - (list - (quote hs-previous) - (hs-to-sx (nth ast 2)) - (nth ast 1))) - ((= head (quote first)) - (if - (> (len ast) 2) - (list - (quote hs-first) - (hs-to-sx (nth ast 2)) - (nth ast 1)) - (list (quote hs-query-first) (nth ast 1)))) - ((= head (quote last)) - (if - (> (len ast) 2) - (list (quote hs-last) (hs-to-sx (nth ast 2)) (nth ast 1)) - (list (quote hs-query-last) (nth ast 1)))) - ((= head (quote add-class)) - (let - ((raw-tgt (nth ast 2))) - (if - (and (list? raw-tgt) (= (first raw-tgt) (quote query))) - (list - (quote for-each) - (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 dom-add-class) - (hs-to-sx raw-tgt) - (nth ast 1))))) - ((= head (quote set-style)) - (list - (quote dom-set-style) - (hs-to-sx (nth ast 3)) - (nth ast 1) - (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)))) - ((= head (quote multi-add-class)) - (let - ((target (hs-to-sx (nth ast 1))) - (classes (rest (rest ast)))) - (cons - (quote do) - (map - (fn (cls) (list (quote dom-add-class) target cls)) - classes)))) - ((= head (quote add-class-when)) - (let - ((cls (nth ast 1)) - (raw-tgt (nth ast 2)) - (when-cond (nth ast 3))) + (= head (quote as)) + (dict-get _hs-converter-registry (nth ast 2))))) + (cond + (reg-conv-fn + (reg-conv-fn + {:hs-to-sx hs-to-sx + :ast ast + :value-ast (nth ast 1) + :type-name (nth ast 2)})) + (reg-cmd-fn + (reg-cmd-fn {:hs-to-sx hs-to-sx :ast ast :head head})) + (true + (cond + ((= head (quote __bind-from-detail__)) (let - ((tgt-expr (cond ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1))) ((and (list? raw-tgt) (= (first raw-tgt) (quote in?)) (list? (nth raw-tgt 1)) (= (first (nth raw-tgt 1)) (quote query))) (list (quote host-call) (hs-to-sx (nth raw-tgt 2)) "querySelectorAll" (nth (nth raw-tgt 1) 1))) (true (hs-to-sx raw-tgt))))) + ((name-str (nth ast 1))) (list - (quote let) + (quote define) + (make-symbol name-str) (list - (list - (quote __hs-matched) - (list - (quote filter) - (list - (quote fn) - (list (quote it)) - (hs-to-sx when-cond)) - tgt-expr))) - (list - (quote begin) - (list - (quote set!) - (quote the-result) - (quote __hs-matched)) - (list (quote set!) (quote it) (quote __hs-matched)) - (list - (quote for-each) - (list - (quote fn) - (list (quote it)) - (list (quote dom-add-class) (quote it) cls)) - (quote __hs-matched)) - (quote __hs-matched)))))) - ((= head (quote add-attr-when)) - (let - ((attr-name (nth ast 1)) - (attr-val (hs-to-sx (nth ast 2))) - (raw-tgt (nth ast 3)) - (when-cond (nth ast 4))) + (quote host-get) + (list (quote host-get) (quote it) "detail") + name-str)))) + ((= head (quote sender)) + (list (quote hs-sender) (quote event))) + ((= head (quote null-literal)) nil) + ((= head (quote not)) + (list (quote not) (hs-to-sx (nth ast 1)))) + ((or (= head (quote and)) (= head (quote or)) (= head (quote >=)) (= head (quote <=)) (= head (quote >)) (= head (quote <))) + (cons head (map hs-to-sx (rest ast)))) + ((= head (quote object-literal)) (let - ((tgt-expr (cond ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1))) (true (hs-to-sx raw-tgt))))) - (list - (quote let) - (list - (list - (quote __hs-matched) - (list - (quote filter) - (list - (quote fn) - (list (quote it)) - (hs-to-sx when-cond)) - tgt-expr))) - (list - (quote begin) - (list - (quote set!) - (quote the-result) - (quote __hs-matched)) - (list (quote set!) (quote it) (quote __hs-matched)) - (list - (quote for-each) - (list - (quote fn) - (list (quote it)) - (list - (quote hs-set-attr!) - (quote it) - attr-name - attr-val)) - (quote __hs-matched)) - (quote __hs-matched)))))) - ((= head (quote multi-remove-class)) - (let - ((target (hs-to-sx (nth ast 1))) - (classes (rest (rest ast)))) - (cons - (quote do) - (map - (fn (cls) (list (quote dom-remove-class) target cls)) - classes)))) - ((= head (quote remove-class)) - (let - ((raw-tgt (nth ast 2))) - (if - (and (list? raw-tgt) (= (first raw-tgt) (quote query))) - (list - (quote for-each) - (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))) - (list - (quote dom-remove-class) - (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)) - (nth ast 1))))) - ((= head (quote remove-element)) - (let - ((tgt (nth ast 1))) - (cond - ((and (list? tgt) (= (first tgt) (quote array-index))) - (let - ((coll (nth tgt 1)) (idx (hs-to-sx (nth tgt 2)))) - (emit-set - coll - (list (quote hs-splice-at!) (hs-to-sx coll) idx)))) - ((and (list? tgt) (= (first tgt) dot-sym)) - (let - ((obj (nth tgt 1)) (prop (nth tgt 2))) - (emit-set - obj - (list (quote hs-dict-without) (hs-to-sx obj) prop)))) - ((and (list? tgt) (= (first tgt) (quote of))) - (let - ((prop-ast (nth tgt 1)) (obj-ast (nth tgt 2))) - (let - ((prop (cond ((string? prop-ast) prop-ast) ((and (list? prop-ast) (= (first prop-ast) (quote ref))) (nth prop-ast 1)) (true (hs-to-sx prop-ast))))) - (emit-set - obj-ast - (list - (quote hs-dict-without) - (hs-to-sx obj-ast) - prop))))) - (true (list (quote dom-remove) (hs-to-sx tgt)))))) - ((= head (quote add-value)) - (let - ((val (hs-to-sx (nth ast 1))) (tgt (nth ast 2))) - (emit-set - tgt - (list (quote hs-add-to!) val (hs-to-sx tgt))))) - ((= head (quote add-attr)) - (let - ((tgt (nth ast 3))) - (list - (quote hs-set-attr!) - (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))) - (emit-set - tgt - (list (quote hs-remove-from!) val (hs-to-sx tgt))))) - ((= head (quote empty-target)) - (let - ((tgt (nth ast 1))) - (cond - ((and (list? tgt) (= (first tgt) (quote local))) - (emit-set - tgt - (list (quote hs-empty-like) (hs-to-sx tgt)))) - (true (list (quote hs-empty-target!) (hs-to-sx tgt)))))) - ((= head (quote open-element)) - (list (quote hs-open!) (hs-to-sx (nth ast 1)))) - ((= head (quote close-element)) - (list (quote hs-close!) (hs-to-sx (nth ast 1)))) - ((= head (quote swap!)) - (let - ((lhs (nth ast 1)) (rhs (nth ast 2))) - (list - (quote let) - (list (list (quote _swap_tmp) (hs-to-sx lhs))) - (list - (quote do) - (emit-set lhs (hs-to-sx rhs)) - (emit-set rhs (quote _swap_tmp)))))) - ((= head (quote morph!)) - (list - (quote hs-morph!) - (hs-to-sx (nth ast 1)) - (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)))) - ((= head (quote remove-css)) - (let - ((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2)))) - (props (nth ast 1))) - (cons - (quote do) - (map - (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))) - ((= head (quote toggle-class-for)) - (list - (quote do) - (list - (quote hs-toggle-class!) - (hs-to-sx (nth ast 2)) - (nth ast 1)) - (list - (quote perform) - (list - (quote list) - (quote io-sleep) - (hs-to-sx (nth ast 3)))) - (list - (quote hs-toggle-class!) - (hs-to-sx (nth ast 2)) - (nth ast 1)))) - ((= head (quote toggle-class-until)) - (let - ((cls (nth ast 1)) - (tgt (hs-to-sx (nth ast 2))) - (event-name (nth ast 3)) - (source (nth ast 4))) - (list - (quote do) - (list (quote hs-toggle-class!) tgt cls) - (list - (quote hs-wait-for) - (if source (hs-to-sx source) (quote me)) - event-name) - (list (quote hs-toggle-class!) tgt cls)))) - ((= head (quote set-on)) - (list - (quote hs-set-on!) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote set-on!)) - (let - ((lhs (nth ast 1)) - (tgt-ast (nth ast 2)) - (val-ast (nth ast 3))) - (if - (and (list? lhs) (= (first lhs) (quote dom-ref))) - (list - (quote hs-dom-set!) - (hs-to-sx tgt-ast) - (nth lhs 1) - (hs-to-sx val-ast)) - (list - (quote hs-set-on!) - (hs-to-sx lhs) - (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))) - ((= head (quote toggle-style)) - (let - ((raw-tgt (nth ast 2))) - (list - (quote hs-toggle-style!) - (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)) - (nth ast 1)))) - ((= head (quote toggle-style-between)) - (list - (quote hs-toggle-style-between!) - (hs-to-sx (nth ast 4)) - (nth ast 1) - (hs-to-sx (nth ast 2)) - (hs-to-sx (nth ast 3)))) - ((= head (quote toggle-style-cycle)) - (list - (quote hs-toggle-style-cycle!) - (hs-to-sx (nth ast 2)) - (nth ast 1) - (cons - (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))) - ((= head (quote toggle-attr-between)) - (list - (quote hs-toggle-attr-between!) - (hs-to-sx (nth ast 4)) - (nth ast 1) - (hs-to-sx (nth ast 2)) - (hs-to-sx (nth ast 3)))) - ((= head (quote toggle-attr-val)) - (list - (quote hs-toggle-attr-val!) - (hs-to-sx (nth ast 3)) - (nth ast 1) - (hs-to-sx (nth ast 2)))) - ((= head (quote toggle-attr-diff)) - (list - (quote hs-toggle-attr-diff!) - (hs-to-sx (nth ast 5)) - (nth ast 1) - (hs-to-sx (nth ast 2)) - (nth ast 3) - (hs-to-sx (nth ast 4)))) - ((= head (quote set!)) - (emit-set (nth ast 1) (hs-to-sx (nth ast 2)))) - ((= head (quote put!)) - (let - ((val (hs-to-sx (nth ast 1))) - (pos (nth ast 2)) - (raw-tgt (nth ast 3))) - (cond - ((and (or (= pos "end") (= pos "start")) (list? raw-tgt) (or (= (first raw-tgt) (quote local)) (= (first raw-tgt) (quote ref)))) - (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)))))) - ((= head (quote if)) - (if - (> (len ast) 3) - (list - (quote if) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)) - (hs-to-sx (nth ast 3))) - (list - (quote when) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2))))) - ((= head (quote do)) - (let - ((expanded (reduce (fn (acc c) (if (and (list? c) (> (len c) 0) (= (first c) (quote wait-for)) (contains? c :destructure)) (let ((dest-names (let ((lst c)) (define scan-dest (fn (i) (cond ((>= i (- (len lst) 1)) (list)) ((= (nth lst i) :destructure) (nth lst (+ i 1))) (true (scan-dest (+ i 2)))))) (scan-dest 2))) (stripped (let ((lst c)) (define strip-dest (fn (i) (cond ((>= i (len lst)) (list)) ((and (< i (- (len lst) 1)) (= (nth lst i) :destructure)) (strip-dest (+ i 2))) (true (cons (nth lst i) (strip-dest (+ i 1))))))) (strip-dest 0)))) (append (append acc (list stripped)) (map (fn (n) (list (quote __bind-from-detail__) n)) dest-names))) (append acc (list c)))) (list) (rest ast)))) - (let - ((compiled (map hs-to-sx expanded))) + ((pairs (nth ast 1))) (if - (and - (> (len compiled) 1) - (some - (fn - (c) - (and - (list? c) - (or - (= (first c) (quote hs-fetch)) - (= (first c) (quote hs-wait)) - (= (first c) (quote hs-wait-for)) - (= (first c) (quote hs-wait-for-or)) - (= (first c) (quote hs-query-first)) - (= (first c) (quote hs-query-all)) - (= (first c) (quote perform))))) - compiled)) - (reduce + (= (len pairs) 0) + (list (quote dict)) + (cons + (quote hs-make-object) + (list + (cons + (quote list) + (map + (fn + (pair) + (list + (quote list) + (if + (and + (list? (first pair)) + (= + (first (first pair)) + (quote computed-key))) + (hs-to-sx (nth (first pair) 1)) + (first pair)) + (hs-to-sx (nth pair 1)))) + pairs))))))) + ((= head (quote template)) + (let + ((raw (nth ast 1))) + (let + ((parts (list)) (buf "") (i 0) (n (len raw))) + (define + tpl-flush (fn - (body cmd) + () + (when + (> (len buf) 0) + (set! parts (append parts (list buf))) + (set! buf "")))) + (define + tpl-read-id + (fn + (j) (if (and - (list? cmd) - (= (first cmd) (quote hs-fetch))) - (list - (quote let) - (list (list (quote it) cmd)) - (list - (quote begin) - (list - (quote set!) - (quote the-result) - (quote it)) - body)) - (list - (quote let) - (list (list (quote it) cmd)) - body))) - (nth compiled (- (len compiled) 1)) - (rest (reverse compiled))) - (cons (quote do) compiled))))) - ((= head (quote wait)) (list (quote hs-wait) (nth ast 1))) - ((= head (quote wait-for)) (emit-wait-for ast)) - ((= head (quote log)) - (list (quote console-log) (hs-to-sx (nth ast 1)))) - ((= head (quote send)) (emit-send ast)) - ((= head (quote trigger)) - (let - ((name (nth ast 1)) - (has-detail - (and - (= (len ast) 4) - (list? (nth ast 2)) - (= (first (nth ast 2)) (quote dict)))) - (tgt (if (= (len ast) 4) (nth ast 3) (nth ast 2))) - (detail (if (= (len ast) 4) (nth ast 2) nil))) + (< j n) + (let + ((c (nth raw j))) + (or + (and (>= c "a") (<= c "z")) + (and (>= c "A") (<= c "Z")) + (and (>= c "0") (<= c "9")) + (= c "_") + (= c ".")))) + (tpl-read-id (+ j 1)) + j))) + (define + tpl-find-close + (fn + (j depth) + (if + (>= j n) + j + (if + (= (nth raw j) "}") + (if + (= depth 1) + j + (tpl-find-close (+ j 1) (- depth 1))) + (if + (= (nth raw j) "{") + (tpl-find-close (+ j 1) (+ depth 1)) + (tpl-find-close (+ j 1) depth)))))) + (define + tpl-collect + (fn + () + (when + (< i n) + (let + ((ch (nth raw i))) + (if + (and + (= ch "\\") + (< (+ i 1) n) + (= (nth raw (+ i 1)) "$")) + (do + (set! buf (str buf "$")) + (set! i (+ i 2)) + (tpl-collect)) + (if + (and (= ch "$") (< (+ i 1) n)) + (if + (= (nth raw (+ i 1)) "{") + (let + ((start (+ i 2))) + (let + ((close (tpl-find-close start 1))) + (let + ((expr-src (slice raw start close))) + (do + (tpl-flush) + (set! + parts + (append + parts + (list + (hs-to-sx + (hs-compile expr-src))))) + (set! i (+ close 1)) + (tpl-collect))))) + (let + ((start (+ i 1))) + (let + ((end (tpl-read-id start))) + (let + ((ident (slice raw start end))) + (do + (tpl-flush) + (set! + parts + (append + parts + (list + (hs-to-sx + (hs-compile ident))))) + (set! i end) + (tpl-collect)))))) + (do + (set! buf (str buf ch)) + (set! i (+ i 1)) + (tpl-collect)))))))) + (tpl-collect) + (tpl-flush) + (cons (quote str) parts)))) + ((= head (quote beep!)) + (list (quote hs-beep) (hs-to-sx (nth ast 1)))) + ((= head (quote array-index)) (list - (quote dom-dispatch) - (hs-to-sx tgt) - 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)))) - (strategy (if (> (len ast) 2) (nth ast 2) "display")) - (when-cond (if (> (len ast) 3) (nth ast 3) nil))) - (if - (nil? when-cond) - (list (quote hs-hide!) tgt strategy) + (quote hs-index) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote array-slice)) + (list + (quote hs-slice) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 3)))) + ((= head (quote pick-first)) + (list + (quote set!) + (quote it) (list - (quote hs-hide-when!) - tgt - strategy + (quote hs-pick-first) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2))))) + ((= head (quote pick-last)) + (list + (quote set!) + (quote it) + (list + (quote hs-pick-last) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2))))) + ((= head (quote pick-random)) + (list + (quote set!) + (quote it) + (list + (quote hs-pick-random) + (hs-to-sx (nth ast 1)) + (if (nil? (nth ast 2)) nil (hs-to-sx (nth ast 2)))))) + ((= head (quote pick-items)) + (list + (quote set!) + (quote it) + (list + (quote hs-pick-items) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 3))))) + ((= head (quote pick-match)) + (list + (quote set!) + (quote it) + (list + (quote hs-pick-match) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2))))) + ((= head (quote pick-matches)) + (list + (quote set!) + (quote it) + (list + (quote hs-pick-matches) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2))))) + ((= head (quote prop-is)) + (list + (quote hs-prop-is) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote coll-where)) + (let + ((raw-coll (hs-to-sx (nth ast 1)))) + (list + (quote filter) (list (quote fn) (list (quote it)) - (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)))) - (strategy (if (> (len ast) 2) (nth ast 2) "display")) - (when-cond (if (> (len ast) 3) (nth ast 3) nil))) + (hs-to-sx (nth ast 2))) + (if + (symbol? raw-coll) + (list + (quote cek-try) + (list (quote fn) (list) raw-coll) + (list (quote fn) (list (quote _e)) nil)) + raw-coll)))) + ((= head (quote coll-sorted)) + (list + (quote hs-sorted-by) + (hs-to-sx (nth ast 1)) + (list + (quote fn) + (list (quote it)) + (hs-to-sx (nth ast 2))))) + ((= head (quote coll-sorted-desc)) + (list + (quote hs-sorted-by-desc) + (hs-to-sx (nth ast 1)) + (list + (quote fn) + (list (quote it)) + (hs-to-sx (nth ast 2))))) + ((= head (quote coll-mapped)) + (list + (quote map) + (list + (quote fn) + (list (quote it)) + (hs-to-sx (nth ast 2))) + (hs-to-sx (nth ast 1)))) + ((= head (quote coll-split)) + (list + (quote hs-split-by) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote coll-joined)) + (list + (quote hs-joined-by) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote method-call)) + (let + ((dot-node (nth ast 1)) + (args (map hs-to-sx (nth ast 2)))) + (if + (and + (list? dot-node) + (or + (= (str (first dot-node)) ".") + (= (str (first dot-node)) "poss"))) + (let + ((receiver-ast (nth dot-node 1)) + (method (nth dot-node 2)) + (sel + (hs-receiver-selector (nth dot-node 1) "poss"))) + (list + (quote let) + (list + (list (quote __hs-recv) (hs-to-sx receiver-ast))) + (list + (quote do) + (list + (quote host-set!) + (list (quote host-global) "window") + "_hs_last_query_sel" + sel) + (list (quote hs-null-raise!) (quote __hs-recv)) + (cons + (quote hs-method-call) + (cons (quote __hs-recv) (cons method args)))))) + (if + (and + (list? dot-node) + (= (first dot-node) (quote ref))) + (list + (quote hs-win-call) + (nth dot-node 1) + (cons (quote list) args)) + (cons + (quote hs-method-call) + (cons (hs-to-sx dot-node) args)))))) + ((= head (quote string-postfix)) + (list (quote str) (hs-to-sx (nth ast 1)) (nth ast 2))) + ((= head (quote block-literal)) + (let + ((params (map make-symbol (nth ast 1))) + (body (hs-to-sx (nth ast 2)))) + (list (quote fn) params body))) + ((= head (quote me)) (quote me)) + ((= head (quote beingTold)) (quote beingTold)) + ((= head (quote it)) (quote it)) + ((= head (quote event)) (quote event)) + ((= head dot-sym) + (let + ((target (let ((t (hs-to-sx (nth ast 1)))) (if (and (symbol? t) (or (= (str t) "window") (= (str t) "document") (= (str t) "navigator") (= (str t) "location") (= (str t) "history") (= (str t) "screen") (= (str t) "localStorage") (= (str t) "sessionStorage") (= (str t) "console"))) (list (quote host-global) (str t)) t))) + (prop (nth ast 2))) + (cond + ((= prop "first") (list (quote hs-first) target)) + ((= prop "last") (list (quote hs-last) target)) + (true (list (quote host-get) target prop))))) + ((= head (make-symbol "poss")) + (let + ((target (hs-to-sx (nth ast 1))) (prop (nth ast 2))) + (list (quote host-get) target prop))) + ((= head (quote ref)) + (cond + ((= (nth ast 1) "selection") + (list (quote hs-get-selection))) + ((= (nth ast 1) "element") (make-symbol "me")) + (else (make-symbol (nth ast 1))))) + ((= head (quote query)) + (list (quote hs-query-first) (nth ast 1))) + ((= head (quote query-scoped)) + (list + (quote hs-query-all-in) + (nth ast 1) + (hs-to-sx (nth ast 2)))) + ((= head (quote attr)) + (list + (quote dom-get-attr) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote style)) + (list + (quote dom-get-style) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote dom-ref)) + (list + (quote hs-dom-get) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote has-class?)) + (list + (quote dom-has-class?) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote local)) + (list (quote hs-scoped-get) (quote me) (nth ast 1))) + ((= head (quote array)) + (cons (quote list) (map hs-to-sx (rest ast)))) + ((= head (quote not)) + (list (quote not) (hs-to-sx (nth ast 1)))) + ((= head (quote no)) + (list (quote hs-falsy?) (hs-to-sx (nth ast 1)))) + ((= head (quote hs-falsy?)) + (list (quote hs-falsy?) (hs-to-sx (nth ast 1)))) + ((= head (quote and)) + (list + (quote and) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote or)) + (list + (quote or) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote =)) + (list + (quote =) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote hs-id=)) + (list + (quote hs-id=) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote +)) + (list + (quote hs-add) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote -)) + (list + (quote -) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote *)) + (list + (quote *) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote /)) + (list + (quote /) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head pct-sym) (if - (nil? when-cond) - (list (quote hs-show!) tgt strategy) + (nil? (nth ast 2)) + (list (quote str) (hs-to-sx (nth ast 1)) "%") + (list + (quote modulo) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2))))) + ((= head (quote empty?)) + (list (quote hs-empty?) (hs-to-sx (nth ast 1)))) + ((= head (quote exists?)) + (list + (quote not) + (list (quote nil?) (hs-to-sx (nth ast 1))))) + ((= head (quote matches?)) + (let + ((left (nth ast 1)) (right (nth ast 2))) + (if + (and (list? right) (= (first right) (quote query))) + (list + (quote hs-matches?) + (hs-to-sx left) + (nth right 1)) + (list + (quote hs-matches?) + (hs-to-sx left) + (hs-to-sx right))))) + ((= head (quote matches-ignore-case?)) + (list + (quote hs-matches-ignore-case?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote starts-with-ic?)) + (list + (quote hs-starts-with-ic?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote ends-with-ic?)) + (list + (quote hs-ends-with-ic?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote starts-with?)) + (list + (quote hs-starts-with?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote ends-with?)) + (list + (quote hs-ends-with?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote precedes?)) + (list + (quote hs-precedes?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote follows?)) + (list + (quote hs-follows?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote contains?)) + (list + (quote hs-contains?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote contains-ignore-case?)) + (list + (quote hs-contains-ignore-case?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote as)) + (list + (quote hs-coerce) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote in?)) + (list + (quote hs-in?) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1)))) + ((= head (quote in-bool?)) + (list + (quote hs-in-bool?) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1)))) + ((= head (quote of)) + (let + ((prop (hs-to-sx (nth ast 1))) + (target (hs-to-sx (nth ast 2)))) + (cond + ((= prop (quote first)) (list (quote first) target)) + ((= prop (quote last)) (list (quote last) target)) + (true (list (quote host-get) target prop))))) + ((= head "!=") + (list + (quote not) + (list + (quote =) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2))))) + ((= head "<") + (list + (quote <) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head ">") + (list + (quote >) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head "<=") + (list + (quote <=) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head ">=") + (list + (quote >=) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote closest)) + (list + (quote dom-closest) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote closest-parent)) + (list + (quote dom-closest) + (list + (quote host-get) + (hs-to-sx (nth ast 2)) + "parentElement") + (nth ast 1))) + ((= head (quote next)) + (list (quote hs-next) (hs-to-sx (nth ast 2)) (nth ast 1))) + ((= head (quote previous)) + (list + (quote hs-previous) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote first)) + (if + (> (len ast) 2) + (list + (quote hs-first) + (hs-to-sx (nth ast 2)) + (nth ast 1)) + (list (quote hs-query-first) (nth ast 1)))) + ((= head (quote last)) + (if + (> (len ast) 2) + (list + (quote hs-last) + (hs-to-sx (nth ast 2)) + (nth ast 1)) + (list (quote hs-query-last) (nth ast 1)))) + ((= head (quote add-class)) + (let + ((raw-tgt (nth ast 2))) + (if + (and + (list? raw-tgt) + (= (first raw-tgt) (quote query))) + (list + (quote for-each) + (list + (quote fn) + (list (quote _el)) + (list + (quote dom-add-class) + (quote _el) + (nth ast 1))) + (list (quote hs-query-all-checked) (nth raw-tgt 1))) + (list + (quote dom-add-class) + (hs-to-sx raw-tgt) + (nth ast 1))))) + ((= head (quote set-style)) + (list + (quote dom-set-style) + (hs-to-sx (nth ast 3)) + (nth ast 1) + (nth ast 2))) + ((= head (quote set-styles)) + (let + ((pairs (nth ast 1)) (tgt (hs-to-sx (nth ast 2)))) (list (quote let) + (list (list (quote __hs-tgt) tgt)) (list + (quote do) + (list (quote hs-null-raise!) (quote __hs-tgt)) + (cons + (quote when) + (cons + (list + (quote not) + (list (quote nil?) (quote __hs-tgt))) + (map + (fn + (p) + (list + (quote dom-set-style) + (quote __hs-tgt) + (first p) + (nth p 1))) + pairs))))))) + ((= head (quote multi-add-class)) + (let + ((target (hs-to-sx (nth ast 1))) + (classes (rest (rest ast)))) + (cons + (quote do) + (map + (fn (cls) (list (quote dom-add-class) target cls)) + classes)))) + ((= head (quote add-class-when)) + (let + ((cls (nth ast 1)) + (raw-tgt (nth ast 2)) + (when-cond (nth ast 3))) + (let + ((tgt-expr (cond ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1))) ((and (list? raw-tgt) (= (first raw-tgt) (quote in?)) (list? (nth raw-tgt 1)) (= (first (nth raw-tgt 1)) (quote query))) (list (quote host-call) (hs-to-sx (nth raw-tgt 2)) "querySelectorAll" (nth (nth raw-tgt 1) 1))) (true (hs-to-sx raw-tgt))))) + (list + (quote let) (list - (quote __hs-show-r) (list - (quote hs-show-when!) - tgt - strategy + (quote __hs-matched) + (list + (quote filter) + (list + (quote fn) + (list (quote it)) + (hs-to-sx when-cond)) + tgt-expr))) + (list + (quote begin) + (list + (quote set!) + (quote the-result) + (quote __hs-matched)) + (list + (quote set!) + (quote it) + (quote __hs-matched)) + (list + (quote for-each) (list (quote fn) (list (quote it)) - (hs-to-sx when-cond))))) + (list (quote dom-add-class) (quote it) cls)) + (quote __hs-matched)) + (quote __hs-matched)))))) + ((= head (quote add-attr-when)) + (let + ((attr-name (nth ast 1)) + (attr-val (hs-to-sx (nth ast 2))) + (raw-tgt (nth ast 3)) + (when-cond (nth ast 4))) + (let + ((tgt-expr (cond ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1))) (true (hs-to-sx raw-tgt))))) + (list + (quote let) + (list + (list + (quote __hs-matched) + (list + (quote filter) + (list + (quote fn) + (list (quote it)) + (hs-to-sx when-cond)) + tgt-expr))) + (list + (quote begin) + (list + (quote set!) + (quote the-result) + (quote __hs-matched)) + (list + (quote set!) + (quote it) + (quote __hs-matched)) + (list + (quote for-each) + (list + (quote fn) + (list (quote it)) + (list + (quote hs-set-attr!) + (quote it) + attr-name + attr-val)) + (quote __hs-matched)) + (quote __hs-matched)))))) + ((= head (quote multi-remove-class)) + (let + ((target (hs-to-sx (nth ast 1))) + (classes (rest (rest ast)))) + (cons + (quote do) + (map + (fn + (cls) + (list (quote dom-remove-class) target cls)) + classes)))) + ((= head (quote remove-class)) + (let + ((raw-tgt (nth ast 2))) + (if + (and + (list? raw-tgt) + (= (first raw-tgt) (quote query))) + (list + (quote for-each) + (list + (quote fn) + (list (quote _el)) + (list + (quote dom-remove-class) + (quote _el) + (nth ast 1))) + (list (quote hs-query-all-checked) (nth raw-tgt 1))) + (list + (quote dom-remove-class) + (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)) + (nth ast 1))))) + ((= head (quote remove-class-when)) + (let + ((cls (nth ast 1)) + (raw-tgt (nth ast 2)) + (when-cond (nth ast 3))) + (let + ((tgt-expr (cond ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1))) (true (hs-to-sx raw-tgt))))) + (list + (quote let) + (list + (list + (quote __hs-matched) + (list + (quote filter) + (list + (quote fn) + (list (quote it)) + (hs-to-sx when-cond)) + tgt-expr))) + (list + (quote for-each) + (list + (quote fn) + (list (quote it)) + (list (quote dom-remove-class) (quote it) cls)) + (quote __hs-matched)))))) + ((= head (quote remove-element)) + (let + ((tgt (nth ast 1))) + (cond + ((and (list? tgt) (= (first tgt) (quote array-index))) + (let + ((coll (nth tgt 1)) + (idx (hs-to-sx (nth tgt 2)))) + (emit-set + coll + (list (quote hs-splice-at!) (hs-to-sx coll) idx)))) + ((and (list? tgt) (= (first tgt) dot-sym)) + (let + ((obj (nth tgt 1)) (prop (nth tgt 2))) + (emit-set + obj + (list + (quote hs-dict-without) + (hs-to-sx obj) + prop)))) + ((and (list? tgt) (= (first tgt) (quote of))) + (let + ((prop-ast (nth tgt 1)) (obj-ast (nth tgt 2))) + (let + ((prop (cond ((string? prop-ast) prop-ast) ((and (list? prop-ast) (= (first prop-ast) (quote ref))) (nth prop-ast 1)) (true (hs-to-sx prop-ast))))) + (emit-set + obj-ast + (list + (quote hs-dict-without) + (hs-to-sx obj-ast) + prop))))) + (true + (let + ((tgt (hs-to-sx tgt))) + (list + (quote let) + (list (list (quote __hs-tgt) tgt)) + (list + (quote do) + (list (quote hs-null-raise!) (quote __hs-tgt)) + (list + (quote when) + (list + (quote not) + (list (quote nil?) (quote __hs-tgt))) + (list (quote dom-remove) (quote __hs-tgt)))))))))) + ((= head (quote add-value)) + (let + ((val (hs-to-sx (nth ast 1))) (tgt (nth ast 2))) + (emit-set + tgt + (list (quote hs-add-to!) val (hs-to-sx tgt))))) + ((= head (quote add-attr)) + (let + ((tgt (nth ast 3))) + (list + (quote hs-set-attr!) + (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))) + (emit-set + tgt + (list (quote hs-remove-from!) val (hs-to-sx tgt))))) + ((= head (quote empty-target)) + (let + ((tgt (nth ast 1))) + (cond + ((and (list? tgt) (= (first tgt) (quote local))) + (emit-set + tgt + (list (quote hs-empty-like) (hs-to-sx tgt)))) + ((and (list? tgt) (= (first tgt) (quote query))) + (list + (quote for-each) + (list + (quote fn) + (list (quote _el)) + (list (quote hs-empty-target!) (quote _el))) + (list (quote hs-query-all) (nth tgt 1)))) + (true (list (quote hs-empty-target!) (hs-to-sx tgt)))))) + ((= head (quote open-element)) + (list (quote hs-open!) (hs-to-sx (nth ast 1)))) + ((= head (quote close-element)) + (list (quote hs-close!) (hs-to-sx (nth ast 1)))) + ((= head (quote swap!)) + (let + ((lhs (nth ast 1)) (rhs (nth ast 2))) + (list + (quote let) + (list (list (quote _swap_tmp) (hs-to-sx lhs))) + (list + (quote do) + (emit-set lhs (hs-to-sx rhs)) + (emit-set rhs (quote _swap_tmp)))))) + ((= head (quote morph!)) + (list + (quote hs-morph!) + (hs-to-sx (nth ast 1)) + (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 let) + (list (list (quote __hs-tgt) tgt)) + (list + (quote do) + (list (quote hs-null-raise!) (quote __hs-tgt)) + (list + (quote when) + (list + (quote not) + (list (quote nil?) (quote __hs-tgt))) + (list + (quote dom-remove-attr) + (quote __hs-tgt) + (nth ast 1))))))) + ((= head (quote remove-css)) + (let + ((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2)))) + (props (nth ast 1))) + (cons + (quote do) + (map + (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))) + ((= head (quote toggle-class-for)) + (list + (quote do) + (list + (quote hs-toggle-class!) + (hs-to-sx (nth ast 2)) + (nth ast 1)) + (list + (quote perform) + (list + (quote list) + (quote io-sleep) + (hs-to-sx (nth ast 3)))) + (list + (quote hs-toggle-class!) + (hs-to-sx (nth ast 2)) + (nth ast 1)))) + ((= head (quote toggle-class-until)) + (let + ((cls (nth ast 1)) + (tgt (hs-to-sx (nth ast 2))) + (event-name (nth ast 3)) + (source (nth ast 4))) + (list + (quote do) + (list (quote hs-toggle-class!) tgt cls) + (list + (quote hs-wait-for) + (if source (hs-to-sx source) (quote me)) + event-name) + (list (quote hs-toggle-class!) tgt cls)))) + ((= head (quote toggle-var-cycle)) + (list + (quote hs-toggle-var-cycle!) + (list (quote host-global) "window") + (nth ast 1) + (cons (quote list) (map hs-to-sx (nth ast 2))))) + ((= head (quote set-on)) + (list + (quote hs-set-on!) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote set-on!)) + (let + ((lhs (nth ast 1)) + (tgt-ast (nth ast 2)) + (val-ast (nth ast 3))) + (if + (and (list? lhs) (= (first lhs) (quote dom-ref))) + (list + (quote hs-dom-set!) + (hs-to-sx tgt-ast) + (nth lhs 1) + (hs-to-sx val-ast)) + (list + (quote hs-set-on!) + (hs-to-sx lhs) + (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))) + ((= head (quote toggle-style)) + (let + ((raw-tgt (nth ast 2))) + (list + (quote hs-toggle-style!) + (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)) + (nth ast 1)))) + ((= head (quote toggle-style-between)) + (list + (quote hs-toggle-style-between!) + (hs-to-sx (nth ast 4)) + (nth ast 1) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 3)))) + ((= head (quote toggle-style-cycle)) + (list + (quote hs-toggle-style-cycle!) + (hs-to-sx (nth ast 2)) + (nth ast 1) + (cons + (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))) + ((= head (quote toggle-attr-between)) + (list + (quote hs-toggle-attr-between!) + (hs-to-sx (nth ast 4)) + (nth ast 1) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 3)))) + ((= head (quote toggle-attr-val)) + (list + (quote hs-toggle-attr-val!) + (hs-to-sx (nth ast 3)) + (nth ast 1) + (hs-to-sx (nth ast 2)))) + ((= head (quote toggle-attr-diff)) + (list + (quote hs-toggle-attr-diff!) + (hs-to-sx (nth ast 5)) + (nth ast 1) + (hs-to-sx (nth ast 2)) + (nth ast 3) + (hs-to-sx (nth ast 4)))) + ((= head (quote set!)) + (emit-set (nth ast 1) (hs-to-sx (nth ast 2)))) + ((= head (quote set-el!)) + (list + (quote hs-set-element!) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote view-transition!)) + (let + ((body (nth ast 2))) + (list + (quote hs-view-transition!) + (hs-to-sx (nth ast 1)) + (if (nil? body) (quote nil) (hs-to-sx body))))) + ((= head (quote put!)) + (let + ((val (hs-to-sx (nth ast 1))) + (pos (nth ast 2)) + (raw-tgt (nth ast 3))) + (cond + ((and (or (= pos "end") (= pos "start")) (list? raw-tgt) (or (= (first raw-tgt) (quote local)) (= (first raw-tgt) (quote ref)))) + (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)))))) + ((= head (quote if)) + (if + (> (len ast) 3) + (list + (quote if) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 3))) + (list + (quote when) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2))))) + ((= head (quote do)) + (let + ((expanded (reduce (fn (acc c) (if (and (list? c) (> (len c) 0) (= (first c) (quote wait-for)) (contains? c :destructure)) (let ((dest-names (let ((lst c)) (define scan-dest (fn (i) (cond ((>= i (- (len lst) 1)) (list)) ((= (nth lst i) :destructure) (nth lst (+ i 1))) (true (scan-dest (+ i 2)))))) (scan-dest 2))) (stripped (let ((lst c)) (define strip-dest (fn (i) (cond ((>= i (len lst)) (list)) ((and (< i (- (len lst) 1)) (= (nth lst i) :destructure)) (strip-dest (+ i 2))) (true (cons (nth lst i) (strip-dest (+ i 1))))))) (strip-dest 0)))) (append (append acc (list stripped)) (map (fn (n) (list (quote __bind-from-detail__) n)) dest-names))) (append acc (list c)))) (list) (rest ast)))) + (let + ((compiled (map hs-to-sx expanded))) + (if + (and + (> (len compiled) 1) + (some + (fn + (c) + (and + (list? c) + (or + (= (first c) (quote hs-fetch)) + (= (first c) (quote hs-fetch-no-throw)) + (= (first c) (quote hs-wait)) + (= (first c) (quote hs-wait-for)) + (= (first c) (quote hs-wait-for-or)) + (= (first c) (quote hs-query-first)) + (= (first c) (quote hs-query-all)) + (= (first c) (quote perform))))) + compiled)) + (reduce + (fn + (body cmd) + (if + (and + (list? cmd) + (or + (= (first cmd) (quote hs-fetch)) + (= (first cmd) (quote hs-fetch-no-throw)))) + (list + (quote let) + (list (list (quote it) cmd)) + (list + (quote begin) + (list + (quote set!) + (quote the-result) + (quote it)) + body)) + (list + (quote let) + (list (list (quote it) cmd)) + body))) + (nth compiled (- (len compiled) 1)) + (rest (reverse compiled))) + (let + ((defs (filter (fn (c) (and (list? c) (> (len c) 0) (= (first c) (quote define)))) compiled)) + (non-defs + (filter + (fn + (c) + (not + (and + (list? c) + (> (len c) 0) + (= (first c) (quote define))))) + compiled))) + (cons (quote do) (append defs non-defs))))))) + ((= head (quote wait)) (list (quote hs-wait) (nth ast 1))) + ((= head (quote wait-for)) (emit-wait-for ast)) + ((= head (quote log)) + (cons + (quote do) + (map + (fn (arg) (list (quote console-log) (hs-to-sx arg))) + (rest ast)))) + ((= head (quote send)) (emit-send ast)) + ((= head (quote trigger)) + (let + ((name (nth ast 1)) + (has-detail + (and + (= (len ast) 4) + (list? (nth ast 2)) + (= (first (nth ast 2)) (quote dict)))) + (tgt (if (= (len ast) 4) (nth ast 3) (nth ast 2))) + (detail (if (= (len ast) 4) (nth ast 2) nil))) + (list + (quote hs-dispatch!) + (hs-to-sx tgt) + 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)))) + (strategy (if (> (len ast) 2) (nth ast 2) "display")) + (when-cond (if (> (len ast) 3) (nth ast 3) nil))) + (if + (nil? when-cond) + (list (quote hs-hide!) tgt strategy) + (list + (quote hs-hide-when!) + tgt + strategy + (list + (quote fn) + (list (quote it)) + (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)))) + (strategy (if (> (len ast) 2) (nth ast 2) "display")) + (when-cond (if (> (len ast) 3) (nth ast 3) nil))) + (if + (nil? when-cond) + (list (quote hs-show!) tgt strategy) + (list + (quote let) + (list + (list + (quote __hs-show-r) + (list + (quote hs-show-when!) + tgt + strategy + (list + (quote fn) + (list (quote it)) + (hs-to-sx when-cond))))) + (list + (quote begin) + (list + (quote set!) + (quote the-result) + (quote __hs-show-r)) + (list (quote set!) (quote it) (quote __hs-show-r)) + (quote __hs-show-r)))))) + ((= head (quote transition)) (emit-transition ast)) + ((= head (quote transition-from)) + (let + ((prop (hs-to-sx (nth ast 1))) + (from-val (hs-to-sx (nth ast 2))) + (to-val (hs-to-sx (nth ast 3))) + (dur (nth ast 4)) + (raw-tgt (nth ast 5))) + (list + (quote hs-transition-from) + (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)) + prop + from-val + to-val + (if dur (hs-to-sx dur) nil)))) + ((= head (quote repeat)) (emit-repeat ast)) + ((= head (quote repeat-until)) + (list + (quote hs-repeat-until) + (list (quote fn) (list) (hs-to-sx (nth ast 1))) + (list (quote fn) (list) (hs-to-sx (nth ast 2))))) + ((= head (quote repeat-while)) + (list + (quote hs-repeat-while) + (list (quote fn) (list) (hs-to-sx (nth ast 1))) + (list (quote fn) (list) (hs-to-sx (nth ast 2))))) + ((= head (quote fetch)) + (list + (if + (nth ast 3) + (quote hs-fetch-no-throw) + (quote hs-fetch)) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote fetch-gql)) + (list + (quote hs-fetch-gql) + (nth ast 1) + (if (nth ast 2) (hs-to-sx (nth ast 2)) nil))) + ((= 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))))) + (cond + ((and (list? raw-fn) (= (first raw-fn) (quote ref))) + (emit-set + (quote the-result) + (list + (quote hs-win-call) + (nth raw-fn 1) + (cons (quote list) args)))) + ((and (list? raw-fn) (= (str (first raw-fn)) ".")) + (let + ((receiver-ast (nth raw-fn 1)) + (prop-name (nth raw-fn 2)) + (sel (hs-receiver-selector (nth raw-fn 1) "dot"))) + (list + (quote let) + (list + (list + (quote __hs-recv) + (hs-to-sx receiver-ast))) + (list + (quote do) + (list + (quote set!) + (quote _hs-last-query-sel) + sel) + (list (quote hs-null-raise!) (quote __hs-recv)) + (emit-set + (quote the-result) + (cons + (list + (quote host-get) + (quote __hs-recv) + prop-name) + args)))))) + (true + (emit-set (quote the-result) (cons fn-expr args)))))) + ((= head (quote return)) + (let + ((val (nth ast 1))) + (if + (nil? val) + (list + (quote raise) + (list (quote list) "hs-return" nil)) + (list + (quote raise) + (list (quote list) "hs-return" (hs-to-sx val)))))) + ((= head (quote throw)) + (list (quote raise) (hs-to-sx (nth ast 1)))) + ((= head (quote settle)) + (let + ((raw-tgt (if (> (len ast) 1) (nth ast 1) nil))) + (list + (quote hs-settle) + (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))))) + ((= head (quote go)) + (list (quote hs-navigate!) (hs-to-sx (nth ast 1)))) + ((= head (quote ask)) + (let + ((val (list (quote hs-ask) (hs-to-sx (nth ast 1))))) + (list + (quote let) + (list (list (quote __hs-a) val)) (list (quote begin) (list (quote set!) (quote the-result) - (quote __hs-show-r)) - (list (quote set!) (quote it) (quote __hs-show-r)) - (quote __hs-show-r)))))) - ((= head (quote transition)) (emit-transition ast)) - ((= head (quote transition-from)) - (let - ((prop (hs-to-sx (nth ast 1))) - (from-val (hs-to-sx (nth ast 2))) - (to-val (hs-to-sx (nth ast 3))) - (dur (nth ast 4)) - (raw-tgt (nth ast 5))) - (list - (quote hs-transition-from) - (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)) - prop - from-val - to-val - (if dur (hs-to-sx dur) nil)))) - ((= head (quote repeat)) (emit-repeat ast)) - ((= head (quote repeat-until)) - (list - (quote hs-repeat-until) - (list (quote fn) (list) (hs-to-sx (nth ast 1))) - (list (quote fn) (list) (hs-to-sx (nth ast 2))))) - ((= head (quote repeat-while)) - (list - (quote hs-repeat-while) - (list (quote fn) (list) (hs-to-sx (nth ast 1))) - (list (quote fn) (list) (hs-to-sx (nth ast 2))))) - ((= head (quote fetch)) - (list (quote hs-fetch) (hs-to-sx (nth ast 1)) (nth ast 2))) - ((= head (quote fetch-gql)) - (list - (quote hs-fetch-gql) - (nth ast 1) - (if (nth ast 2) (hs-to-sx (nth ast 2)) nil))) - ((= 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))) - ((= head (quote return)) - (let - ((val (nth ast 1))) - (if - (nil? val) - (list (quote raise) (list (quote list) "hs-return" nil)) - (list - (quote raise) - (list (quote list) "hs-return" (hs-to-sx val)))))) - ((= head (quote throw)) - (list (quote raise) (hs-to-sx (nth ast 1)))) - ((= head (quote settle)) - (list (quote hs-settle) (quote me))) - ((= head (quote go)) - (list (quote hs-navigate!) (hs-to-sx (nth ast 1)))) - ((= head (quote ask)) - (let - ((val (list (quote hs-ask) (hs-to-sx (nth ast 1))))) - (list - (quote let) - (list (list (quote __hs-a) val)) - (list - (quote begin) - (list (quote set!) (quote the-result) (quote __hs-a)) - (list (quote set!) (quote it) (quote __hs-a)) - (quote __hs-a))))) - ((= head (quote answer)) - (let - ((val (list (quote hs-answer) (hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 3))))) - (list - (quote let) - (list (list (quote __hs-a) val)) - (list - (quote begin) - (list (quote set!) (quote the-result) (quote __hs-a)) - (list (quote set!) (quote it) (quote __hs-a)) - (quote __hs-a))))) - ((= head (quote answer-alert)) - (let - ((val (list (quote hs-answer-alert) (hs-to-sx (nth ast 1))))) - (list - (quote let) - (list (list (quote __hs-a) val)) - (list - (quote begin) - (list (quote set!) (quote the-result) (quote __hs-a)) - (list (quote set!) (quote it) (quote __hs-a)) - (quote __hs-a))))) - ((= head (quote __get-cmd)) - (let - ((val (hs-to-sx (nth ast 1)))) - (list - (quote let) - (list (list (quote __hs-g) val)) - (list - (quote begin) - (list (quote set!) (quote the-result) (quote __hs-g)) - (list (quote set!) (quote it) (quote __hs-g)) - (quote __hs-g))))) - ((= head (quote append!)) - (let - ((tgt (hs-to-sx (nth ast 2))) - (val (hs-to-sx (nth ast 1))) - (raw-tgt (nth ast 2))) - (cond - ((symbol? tgt) - (list - (quote set!) - tgt - (list (quote hs-append) tgt val))) - ((and (list? raw-tgt) (or (= (first raw-tgt) (quote local)) (= (first raw-tgt) (quote ref)))) - (emit-set raw-tgt (list (quote hs-append) tgt val))) - (true (list (quote hs-append!) val tgt))))) - ((= head (quote tell)) - (let - ((tgt (hs-to-sx (nth ast 1)))) - (list - (quote let) - (list - (list (quote me) tgt) - (list (quote you) tgt) - (list (quote yourself) tgt)) - (hs-to-sx (nth ast 2))))) - ((= head (quote for)) (emit-for ast)) - ((= head (quote take!)) - (let - ((kind (nth ast 1)) - (name (nth ast 2)) - (from-sel (if (> (len ast) 3) (nth ast 3) nil)) - (for-tgt (if (> (len ast) 4) (nth ast 4) nil)) - (attr-val (if (> (len ast) 5) (nth ast 5) nil)) - (with-val (if (> (len ast) 6) (nth ast 6) nil))) + (quote __hs-a)) + (list (quote set!) (quote it) (quote __hs-a)) + (quote __hs-a))))) + ((= head (quote answer)) (let - ((target (if for-tgt (hs-to-sx for-tgt) (quote me))) - (scope - (cond - ((nil? from-sel) nil) - ((and (list? from-sel) (= (first from-sel) (quote query))) - (list (quote hs-query-all) (nth from-sel 1))) - (true (hs-to-sx from-sel)))) - (with-sx - (if - with-val - (if - (string? with-val) - with-val - (hs-to-sx with-val)) - nil))) - (cond - ((and (= kind "attr") (or attr-val with-val)) - (list - (quote hs-take!) - target - kind - name - scope - attr-val - with-sx)) - ((and (= kind "class") with-val) - (list - (quote hs-take!) - target - kind - name - scope - nil - with-sx)) - (true (list (quote hs-take!) target kind name scope)))))) - ((= head (quote make)) (emit-make ast)) - ((= 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)))) - ((= head (quote increment!)) - (if - (= (len ast) 3) - (emit-inc (nth ast 1) 1 (nth ast 2)) - (emit-inc - (nth ast 1) - (nth ast 2) - (if (> (len ast) 3) (nth ast 3) nil)))) - ((= head (quote decrement!)) - (if - (= (len ast) 3) - (emit-dec (nth ast 1) 1 (nth ast 2)) - (emit-dec - (nth ast 1) - (nth ast 2) - (if (> (len ast) 3) (nth ast 3) nil)))) - ((= head (quote break)) (list (quote raise) "hs-break")) - ((= head (quote continue)) - (list (quote raise) "hs-continue")) - ((= head (quote exit)) nil) - ((= head (quote live-no-op)) nil) - ((= head (quote when-feat-no-op)) nil) - ((= head (quote on)) (emit-on ast)) - ((= head (quote when-changes)) - (let - ((expr (nth ast 1)) (body (nth ast 2))) - (if - (and (list? expr) (= (first expr) (quote dom-ref))) + ((val (list (quote hs-answer) (hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 3))))) (list - (quote hs-dom-watch!) - (hs-to-sx (nth expr 2)) - (nth expr 1) - (list (quote fn) (list (quote it)) (hs-to-sx body))) - nil))) - ((= head (quote init)) - (list - (quote hs-init) - (list (quote fn) (list) (hs-to-sx (nth ast 1))))) - ((= head (quote def)) - (let - ((body (hs-to-sx (nth ast 3))) - (params - (map - (fn - (p) + (quote let) + (list (list (quote __hs-a) val)) + (list + (quote begin) + (list + (quote set!) + (quote the-result) + (quote __hs-a)) + (list (quote set!) (quote it) (quote __hs-a)) + (quote __hs-a))))) + ((= head (quote answer-alert)) + (let + ((val (list (quote hs-answer-alert) (hs-to-sx (nth ast 1))))) + (list + (quote let) + (list (list (quote __hs-a) val)) + (list + (quote begin) + (list + (quote set!) + (quote the-result) + (quote __hs-a)) + (list (quote set!) (quote it) (quote __hs-a)) + (quote __hs-a))))) + ((= head (quote __get-cmd)) + (let + ((val (hs-to-sx (nth ast 1)))) + (list + (quote let) + (list (list (quote __hs-g) val)) + (list + (quote begin) + (list + (quote set!) + (quote the-result) + (quote __hs-g)) + (list (quote set!) (quote it) (quote __hs-g)) + (quote __hs-g))))) + ((= head (quote append!)) + (let + ((tgt (hs-to-sx (nth ast 2))) + (val (hs-to-sx (nth ast 1))) + (raw-tgt (nth ast 2))) + (cond + ((symbol? tgt) + (list + (quote set!) + tgt + (list (quote hs-append) tgt val))) + ((and (list? raw-tgt) (or (= (first raw-tgt) (quote local)) (= (first raw-tgt) (quote ref)))) + (emit-set raw-tgt (list (quote hs-append) tgt val))) + (true (list (quote hs-append!) val tgt))))) + ((= head (quote tell)) + (let + ((tgt (hs-to-sx (nth ast 1)))) + (list + (quote let) + (list + (list (quote beingTold) tgt) + (list (quote you) tgt) + (list (quote yourself) tgt)) + (hs-to-sx (nth ast 2))))) + ((= head (quote for)) (emit-for ast)) + ((= head (quote take!)) + (let + ((kind (nth ast 1)) + (name (nth ast 2)) + (from-sel (if (> (len ast) 3) (nth ast 3) nil)) + (for-tgt (if (> (len ast) 4) (nth ast 4) nil)) + (attr-val (if (> (len ast) 5) (nth ast 5) nil)) + (with-val (if (> (len ast) 6) (nth ast 6) nil))) + (let + ((target (if for-tgt (hs-to-sx for-tgt) (quote me))) + (scope + (cond + ((nil? from-sel) nil) + ((and (list? from-sel) (= (first from-sel) (quote query))) + (list (quote hs-query-all) (nth from-sel 1))) + (true (hs-to-sx from-sel)))) + (with-sx (if - (and (list? p) (= (first p) (quote ref))) - (make-symbol (nth p 1)) - (make-symbol p))) - (nth ast 2)))) + with-val + (if + (string? with-val) + with-val + (hs-to-sx with-val)) + nil))) + (cond + ((and (= kind "attr") (or attr-val with-val)) + (list + (quote hs-take!) + target + kind + name + scope + attr-val + with-sx)) + ((and (= kind "class") with-val) + (list + (quote hs-take!) + target + kind + name + scope + nil + with-sx)) + (true (list (quote hs-take!) target kind name scope)))))) + ((= head (quote make)) (emit-make ast)) + ((= head (quote install)) + (let + ((bname (nth ast 1))) + (cons + (make-symbol bname) + (cons + (quote me) + (map + (fn + (arg) + (if + (and + (list? arg) + (= (first arg) (quote type-assert))) + (+ (nth arg 2) 0) + (hs-to-sx arg))) + (rest (rest ast))))))) + ((= head (quote measure)) + (list (quote hs-measure) (hs-to-sx (nth ast 1)))) + ((= head (quote increment!)) + (if + (= (len ast) 3) + (emit-inc (nth ast 1) 1 (nth ast 2)) + (emit-inc + (nth ast 1) + (nth ast 2) + (if (> (len ast) 3) (nth ast 3) nil)))) + ((= head (quote decrement!)) + (if + (= (len ast) 3) + (emit-dec (nth ast 1) 1 (nth ast 2)) + (emit-dec + (nth ast 1) + (nth ast 2) + (if (> (len ast) 3) (nth ast 3) nil)))) + ((= head (quote break)) (list (quote raise) "hs-break")) + ((= head (quote continue)) + (list (quote raise) "hs-continue")) + ((= head (quote exit)) nil) + ((= head (quote live-no-op)) nil) + ((= head (quote when-feat-no-op)) nil) + ((= head (quote bind-feat)) nil) + ((= head (quote socket)) + (let + ((name-path (nth ast 1)) + (url (nth ast 2)) + (timeout (nth ast 3)) + (on-message (nth ast 4))) + (let + ((handler-sx (if (and (list? on-message) (= (first on-message) (quote on-message))) (list (quote fn) (list (quote event)) (hs-to-sx (nth on-message 2))) nil))) + (let + ((json? (if (and (list? on-message) (= (first on-message) (quote on-message))) (nth on-message 1) false))) + (list + (quote hs-socket-register!) + (cons + (quote list) + (map (fn (seg) seg) name-path)) + (hs-to-sx url) + (hs-to-sx timeout) + handler-sx + json?))))) + ((= head (quote on)) (emit-on ast)) + ((= head (quote when-changes)) + (let + ((expr (nth ast 1)) (body (nth ast 2))) + (cond + ((and (list? expr) (= (first expr) (quote dom-ref))) + (list + (quote hs-dom-watch!) + (hs-to-sx (nth expr 2)) + (nth expr 1) + (list + (quote fn) + (list (quote it)) + (hs-to-sx body)))) + ((and (list? expr) (= (first expr) (quote local))) + (list + (quote hs-scoped-watch!) + (quote me) + (nth expr 1) + (list + (quote fn) + (list (quote it)) + (hs-to-sx body)))) + (true nil)))) + ((= head (quote init)) (list - (quote define) - (make-symbol (nth ast 1)) + (quote hs-init) + (list (quote fn) (list) (hs-to-sx (nth ast 1))))) + ((= head (quote def)) + (let + ((body (hs-to-sx (nth ast 3))) + (params + (map + (fn + (p) + (if + (and (list? p) (= (first p) (quote ref))) + (make-symbol (nth p 1)) + (make-symbol p))) + (nth ast 2)))) + (list + (quote define) + (make-symbol (nth ast 1)) + (list + (quote let) + (list + (list + (quote _hs-def-val) + (list + (quote fn) + params + (list + (quote guard) + (list + (quote _e) + (list + (quote true) + (list + (quote if) + (list + (quote and) + (list (quote list?) (quote _e)) + (list + (quote =) + (list (quote first) (quote _e)) + "hs-return")) + (list (quote nth) (quote _e) 1) + (list (quote raise) (quote _e))))) + body)))) + (list + (quote do) + (list + (quote host-set!) + (list (quote host-global) "window") + (nth ast 1) + (quote _hs-def-val)) + (quote _hs-def-val)))))) + ((= head (quote behavior)) (emit-behavior ast)) + ((= head (quote sx-eval)) + (let + ((src (nth ast 1))) + (if + (string? src) + (first (sx-parse src)) + (list (quote cek-eval) (hs-to-sx src))))) + ((= head (quote component)) (make-symbol (nth ast 1))) + ((= head (quote render)) + (let + ((comp-raw (nth ast 1)) + (kwargs (nth ast 2)) + (pos (if (> (len ast) 3) (nth ast 3) nil)) + (target + (if (> (len ast) 4) (hs-to-sx (nth ast 4)) nil))) + (let + ((comp (if (string? comp-raw) (make-symbol comp-raw) (hs-to-sx comp-raw)))) + (define + emit-kw-pairs + (fn + (pairs) + (if + (< (len pairs) 2) + (list) + (cons + (make-keyword (first pairs)) + (cons + (hs-to-sx (nth pairs 1)) + (emit-kw-pairs (rest (rest pairs)))))))) + (let + ((render-call (cons (quote render-to-html) (cons comp (emit-kw-pairs kwargs))))) + (if + pos + (list + (quote hs-put!) + render-call + pos + (if target target (quote me))) + render-call))))) + ((= head (quote not-in?)) + (list + (quote not) + (list + (quote hs-contains?) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1))))) + ((= head (quote in?)) + (list + (quote hs-in?) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1)))) + ((= head (quote type-check)) + (list + (quote hs-type-check) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote type-check-strict)) + (list + (quote hs-type-check-strict) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote type-assert)) + (list + (quote hs-type-assert) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote type-assert-strict)) + (list + (quote hs-type-assert-strict) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote strict-eq)) + (list + (quote hs-strict-eq) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote eq-ignore-case)) + (list + (quote hs-eq-ignore-case) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote some)) + (list + (quote some) (list (quote fn) - params - (list - (quote guard) - (list - (quote _e) - (list - (quote true) - (list - (quote if) - (list - (quote and) - (list (quote list?) (quote _e)) - (list - (quote =) - (list (quote first) (quote _e)) - "hs-return")) - (list (quote nth) (quote _e) 1) - (list (quote raise) (quote _e))))) - body))))) - ((= head (quote behavior)) (emit-behavior ast)) - ((= head (quote sx-eval)) - (let - ((src (nth ast 1))) - (if - (string? src) - (first (sx-parse src)) - (list (quote cek-eval) (hs-to-sx src))))) - ((= head (quote component)) (make-symbol (nth ast 1))) - ((= head (quote render)) - (let - ((comp-raw (nth ast 1)) - (kwargs (nth ast 2)) - (pos (if (> (len ast) 3) (nth ast 3) nil)) - (target - (if (> (len ast) 4) (hs-to-sx (nth ast 4)) nil))) + (list (make-symbol (nth ast 1))) + (hs-to-sx (nth ast 3))) + (hs-to-sx (nth ast 2)))) + ((= head (quote every)) + (list + (quote every?) + (list + (quote fn) + (list (make-symbol (nth ast 1))) + (hs-to-sx (nth ast 3))) + (hs-to-sx (nth ast 2)))) + ((= head (quote scroll!)) + (list + (quote hs-scroll!) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote select!)) + (list (quote hs-select!) (hs-to-sx (nth ast 1)))) + ((= head (quote reset!)) (let - ((comp (if (string? comp-raw) (make-symbol comp-raw) (hs-to-sx comp-raw)))) - (define - emit-kw-pairs - (fn - (pairs) - (if - (< (len pairs) 2) - (list) - (cons - (make-keyword (first pairs)) - (cons - (hs-to-sx (nth pairs 1)) - (emit-kw-pairs (rest (rest pairs)))))))) - (let - ((render-call (cons (quote render-to-html) (cons comp (emit-kw-pairs kwargs))))) - (if - pos + ((raw-tgt (nth ast 1))) + (cond + ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list - (quote hs-put!) - render-call - pos - (if target target (quote me))) - render-call))))) - ((= head (quote not-in?)) - (list - (quote not) + (quote hs-reset!) + (list (quote hs-query-all) (nth raw-tgt 1)))) + (true (list (quote hs-reset!) (hs-to-sx raw-tgt)))))) + ((= head (quote default!)) + (let + ((tgt-ast (nth ast 1)) + (read (hs-to-sx (nth ast 1))) + (v (hs-to-sx (nth ast 2)))) + (list + (quote when) + (list (quote hs-default?) read) + (emit-set tgt-ast v)))) + ((= head (quote hs-is)) (list - (quote hs-contains?) - (hs-to-sx (nth ast 2)) - (hs-to-sx (nth ast 1))))) - ((= head (quote in?)) - (list - (quote hs-contains?) - (hs-to-sx (nth ast 2)) - (hs-to-sx (nth ast 1)))) - ((= head (quote type-check)) - (list - (quote hs-type-check) - (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote type-check-strict)) - (list - (quote hs-type-check-strict) - (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote type-assert)) - (list - (quote hs-type-assert) - (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote type-assert-strict)) - (list - (quote hs-type-assert-strict) - (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote strict-eq)) - (list - (quote hs-strict-eq) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote eq-ignore-case)) - (list - (quote hs-eq-ignore-case) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote some)) - (list - (quote some) - (list - (quote fn) - (list (make-symbol (nth ast 1))) - (hs-to-sx (nth ast 3))) - (hs-to-sx (nth ast 2)))) - ((= head (quote every)) - (list - (quote every?) - (list - (quote fn) - (list (make-symbol (nth ast 1))) - (hs-to-sx (nth ast 3))) - (hs-to-sx (nth ast 2)))) - ((= head (quote scroll!)) - (list - (quote hs-scroll!) - (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote select!)) - (list (quote hs-select!) (hs-to-sx (nth ast 1)))) - ((= head (quote reset!)) - (let - ((raw-tgt (nth ast 1))) - (cond - ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) + (quote hs-is) + (hs-to-sx (nth ast 1)) + (list + (quote fn) + (list) + (hs-to-sx (nth (nth ast 2) 2))) + (nth ast 3))) + ((= head (quote halt!)) + (list (quote hs-halt!) (quote event) (nth ast 1))) + ((= head (quote focus!)) + (list (quote dom-focus) (hs-to-sx (nth ast 1)))) + ((= head (quote js-block)) + (let + ((params (nth ast 1)) (js-src (nth ast 2))) + (let + ((bound-syms (map (fn (p) (make-symbol p)) params))) (list - (quote hs-reset!) - (list (quote hs-query-all) (nth raw-tgt 1)))) - (true (list (quote hs-reset!) (hs-to-sx raw-tgt)))))) - ((= head (quote default!)) - (let - ((tgt-ast (nth ast 1)) - (read (hs-to-sx (nth ast 1))) - (v (hs-to-sx (nth ast 2)))) - (list - (quote when) - (list (quote hs-default?) read) - (emit-set tgt-ast v)))) - ((= head (quote hs-is)) - (list - (quote hs-is) - (hs-to-sx (nth ast 1)) - (list (quote fn) (list) (hs-to-sx (nth (nth ast 2) 2))) - (nth ast 3))) - ((= head (quote halt!)) - (list (quote hs-halt!) (quote event) (nth ast 1))) - ((= head (quote focus!)) - (list (quote dom-focus) (hs-to-sx (nth ast 1)))) - (true ast)))))))) + (quote let) + (list + (list + (quote __hs-js) + (list + (quote hs-js-exec) + (cons (quote list) params) + js-src + (cons (quote list) bound-syms)))) + (list + (quote begin) + (list (quote set!) (quote it) (quote __hs-js)) + (quote __hs-js)))))) + (true ast)))))))))))) ;; ── Convenience: source → SX ───────────────────────────────── +(define + hs-receiver-selector + (fn + (ast notation) + (cond + ((and (list? ast) (= (str (first ast)) "ref")) (nth ast 1)) + ((and (list? ast) (= (str (first ast)) ".")) + (str (hs-receiver-selector (nth ast 1) notation) "." (nth ast 2))) + ((and (list? ast) (= (str (first ast)) "poss")) + (str (hs-receiver-selector (nth ast 1) "poss") "'s " (nth ast 2))) + (true "?")))) + (define hs-to-sx-from-source (fn (src) (hs-to-sx (hs-compile src)))) \ No newline at end of file diff --git a/lib/hyperscript/integration.sx b/lib/hyperscript/integration.sx index 29931ce3..43132359 100644 --- a/lib/hyperscript/integration.sx +++ b/lib/hyperscript/integration.sx @@ -19,6 +19,7 @@ (define reserved (list + (quote beingTold) (quote me) (quote it) (quote event) @@ -65,7 +66,10 @@ (list (quote me)) (list (quote let) - (list (list (quote it) nil) (list (quote event) nil)) + (list + (list (quote beingTold) (quote me)) + (list (quote it) nil) + (list (quote event) nil)) guarded)))))))))) ;; ── Activate a single element ─────────────────────────────────── @@ -73,23 +77,82 @@ ;; Marks the element to avoid double-activation. (define - hs-activate! + hs-register-scripts! (fn - (el) - (let - ((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script"))) - (when - (and src (not (= src prev))) - (hs-log-event! "hyperscript:init") - (dom-set-data el "hs-script" src) - (dom-set-data el "hs-active" true) - (dom-set-attr el "data-hyperscript-powered" "true") - (let ((handler (hs-handler src))) (handler el)))))) + () + (for-each + (fn + (script) + (when + (not (dom-get-data script "hs-script-loaded")) + (let + ((src (host-get script "innerHTML"))) + (guard + (_e (true nil)) + (let + ((handler (eval-expr-cek (hs-to-sx-from-source src)))) + (handler (dom-body))))))) + (hs-query-all "script[type=text/hyperscript]")))) ;; ── Boot: scan entire document ────────────────────────────────── ;; Called once at page load. Finds all elements with _ attribute, ;; compiles their hyperscript, and activates them. +(define + hs-scripting-disabled? + (fn + (el) + (if + (= el nil) + false + (if + (dom-get-attr el "disable-scripting") + true + (hs-scripting-disabled? (dom-parent el)))))) + +;; ── Boot subtree: for dynamic content ─────────────────────────── +;; Called after HTMX swaps or dynamic DOM insertion. +;; Only activates elements within the given root. + +(define + hs-activate! + (fn + (el) + (do + (hs-register-scripts!) + (let + ((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script"))) + (when + (and src (not (= src prev)) (not (hs-scripting-disabled? el))) + (when + (dom-dispatch el "hyperscript:before:init" nil) + (hs-log-event! "hyperscript:init") + (dom-set-data el "hs-script" src) + (dom-set-data el "hs-active" true) + (dom-set-attr el "data-hyperscript-powered" "true") + (host-set! (host-global "window") "__hs_current_me" el) + (guard + (_e + (true + (do + (dom-dispatch el "hyperscript:parse-error" {:errors (list _e)}) + nil))) + (let + ((handler (hs-handler src))) + (let + ((el-type (dom-get-attr el "type")) + (comp-name (dom-get-attr el "component"))) + (let + ((safe-handler (fn (e) (host-call-fn handler (list e))))) + (if + (= el-type "text/hyperscript-template") + (for-each + safe-handler + (hs-query-all (or comp-name ""))) + (safe-handler el)))))) + (host-set! (host-global "window") "__hs_current_me" nil) + (dom-dispatch el "hyperscript:after:init" nil))))))) + (define hs-deactivate! (fn @@ -101,10 +164,6 @@ (dom-set-data el "hs-active" false) (dom-set-data el "hs-script" nil)))) -;; ── Boot subtree: for dynamic content ─────────────────────────── -;; Called after HTMX swaps or dynamic DOM insertion. -;; Only activates elements within the given root. - (define hs-boot! (fn diff --git a/lib/hyperscript/parser.sx b/lib/hyperscript/parser.sx index 6dfdaa60..7b08aa96 100644 --- a/lib/hyperscript/parser.sx +++ b/lib/hyperscript/parser.sx @@ -3,13 +3,28 @@ ;; Input: list of {:type T :value V :pos P} tokens from hs-tokenize ;; Output: SX AST forms that map to runtime primitives +;; ── Feature plugin registry ─────────────────────────────────────── +;; Plugins call (hs-register-feature! "name" parse-fn) at load time. +;; parse-fn is (fn (ctx) ...) where ctx is a dict exposing parser +;; helpers (:adv! :tp-val :tp-type :parse-cmd-list ...) and the +;; built-in parse-X-feat dispatch fns. +(begin + (define _hs-feature-registry {}) + (define + hs-register-feature! + (fn (name parse-fn) (dict-set! _hs-feature-registry name parse-fn)))) + ;; ── Parser entry point ──────────────────────────────────────────── (define hs-parse (fn (tokens src) (let - ((p 0) (tok-len (len tokens))) + ((tokens (filter (fn (t) (not (= (get t "type") "whitespace"))) tokens)) + (p 0) + (tok-len + (len + (filter (fn (t) (not (= (get t "type") "whitespace"))) tokens)))) (define tp (fn () (if (< p tok-len) (nth tokens p) nil))) (define tp-type @@ -21,6 +36,16 @@ adv! (fn () (let ((t (nth tokens p))) (set! p (+ p 1)) t))) (define at-end? (fn () (or (>= p tok-len) (= (tp-type) "eof")))) + (define cur-start (fn () (if (< p tok-len) (get (tp) "pos") 0))) + (define cur-line (fn () (if (< p tok-len) (get (tp) "line") 1))) + (define + prev-end + (fn () (if (> p 0) (get (nth tokens (- p 1)) "end") 0))) + (define + hs-ast-wrap + (fn + (raw kind start end-pos line fields) + (if hs-span-mode {:children raw :end end-pos :kind kind :line line :src src :start start :hs-ast true :fields fields} raw))) (define match-kw (fn @@ -57,31 +82,70 @@ ((typ (tp-type)) (val (tp-val))) (cond ((or (= typ "ident") (= typ "keyword")) - (do (adv!) (parse-prop-chain (list (quote .) owner val)))) + (do + (adv!) + (let + ((base (list (quote poss) owner val))) + (if + (= (tp-type) "bracket-open") + (parse-poss base) + (parse-prop-chain base))))) ((= typ "attr") (do (adv!) (list (quote attr) val owner))) ((= typ "class") (let ((prop (get (adv!) "value"))) - (parse-prop-chain (list (quote .) owner prop)))) + (parse-prop-chain (list (quote poss) owner prop)))) ((= typ "style") (do (adv!) (list (quote style) val owner))) (true owner))))) (define parse-prop-chain (fn (base) - (if - (and (= (tp-type) "class") (not (at-end?))) - (let - ((prop (tp-val))) - (do - (adv!) - (parse-prop-chain (list (make-symbol ".") base prop)))) + (let + ((base-start (if (and (dict? base) (get base :hs-ast)) (get base :start) (cur-start))) + (base-line + (if + (and (dict? base) (get base :hs-ast)) + (get base :line) + (cur-line)))) (if - (= (tp-type) "paren-open") + (and (= (tp-type) "class") (not (at-end?))) (let - ((args (parse-call-args))) - (parse-prop-chain (list (quote method-call) base args))) - base)))) + ((prop (tp-val))) + (do + (adv!) + (parse-prop-chain + (hs-ast-wrap + (list (make-symbol ".") base prop) + "member" + base-start + (prev-end) + base-line + {:root base})))) + (if + (= (tp-type) "paren-open") + (let + ((args (parse-call-args))) + (parse-prop-chain + (hs-ast-wrap + (list (quote method-call) base args) + "call" + base-start + (prev-end) + base-line + {:root base}))) + (if + (and + (= (tp-type) "op") + (= (tp-val) "'s") + (not (at-end?))) + (let + ((poss-prop (begin (adv!) (tp-val)))) + (do + (adv!) + (parse-prop-chain + (list (make-symbol "poss") base poss-prop)))) + base)))))) (define parse-trav (fn @@ -92,19 +156,43 @@ ((and (= kind (quote closest)) (= typ "ident") (= val "parent")) (do (adv!) (parse-trav (quote closest-parent)))) ((= typ "selector") - (do (adv!) (list kind val (list (quote me))))) + (do + (adv!) + (list + kind + val + (if + (and (= kind (quote closest)) (match-kw "to")) + (parse-expr) + (list (quote beingTold)))))) ((= typ "class") - (do (adv!) (list kind (str "." val) (list (quote me))))) + (do + (adv!) + (list + kind + (str "." val) + (if + (and (= kind (quote closest)) (match-kw "to")) + (parse-expr) + (list (quote beingTold)))))) ((= typ "id") - (do (adv!) (list kind (str "#" val) (list (quote me))))) + (do + (adv!) + (list + kind + (str "#" val) + (if + (and (= kind (quote closest)) (match-kw "to")) + (parse-expr) + (list (quote beingTold)))))) ((= typ "attr") (do (adv!) (list (quote attr) val - (list kind (str "[" val "]") (list (quote me)))))) - (true (list kind "*" (list (quote me)))))))) + (list kind (str "[" val "]") (list (quote beingTold)))))) + (true (list kind "*" (list (quote beingTold)))))))) (define parse-pos-kw (fn @@ -124,8 +212,24 @@ (let ((typ (tp-type)) (val (tp-val))) (cond - ((= typ "number") (do (adv!) (parse-dur val))) - ((= typ "string") (do (adv!) val)) + ((= typ "number") + (let + ((s (cur-start)) (l (cur-line))) + (do + (adv!) + (hs-ast-wrap + (parse-dur val) + "number" + s + (prev-end) + l + {})))) + ((= typ "string") + (let + ((s (cur-start)) (l (cur-line))) + (do + (adv!) + (hs-ast-wrap val "string" s (prev-end) l {})))) ((= typ "template") (do (adv!) (list (quote template) val))) ((and (= typ "keyword") (= val "true")) (do (adv!) true)) ((and (= typ "keyword") (= val "false")) (do (adv!) false)) @@ -190,26 +294,51 @@ ((and (= typ "keyword") (= val "last")) (do (adv!) (parse-pos-kw (quote last)))) ((= typ "id") - (do (adv!) (list (quote query) (str "#" val)))) + (let + ((s (cur-start)) (l (cur-line))) + (do + (adv!) + (hs-ast-wrap + (list (quote query) (str "#" val)) + "selector" + s + (prev-end) + l + {})))) ((= typ "selector") + (let + ((s (cur-start)) (l (cur-line))) + (do + (adv!) + (hs-ast-wrap + (if + (and (= (tp-type) "keyword") (= (tp-val) "in")) + (do + (adv!) + (list + (quote query-scoped) + val + (parse-cmp + (parse-arith (parse-poss (parse-atom)))))) + (list (quote query) val)) + "selector" + s + (prev-end) + l + {})))) + ((= typ "attr") (do (adv!) - (if - (and (= (tp-type) "keyword") (= (tp-val) "in")) - (do - (adv!) - (list - (quote query-scoped) - val - (parse-cmp (parse-arith (parse-poss (parse-atom)))))) - (list (quote query) val)))) - ((= typ "attr") - (do (adv!) (list (quote attr) val (list (quote me))))) + (list (quote attr) val (list (quote beingTold))))) ((= typ "style") - (do (adv!) (list (quote style) val (list (quote me))))) + (do + (adv!) + (list (quote style) val (list (quote beingTold))))) ((= typ "local") (do (adv!) (list (quote local) val))) ((= typ "hat") - (do (adv!) (list (quote dom-ref) val (list (quote me))))) + (do + (adv!) + (list (quote dom-ref) val (list (quote beingTold))))) ((and (= typ "keyword") (= val "dom")) (do (adv!) @@ -217,10 +346,31 @@ ((name (tp-val))) (do (adv!) - (list (quote dom-ref) name (list (quote me))))))) + (list (quote dom-ref) name (list (quote beingTold))))))) ((= typ "class") - (do (adv!) (list (quote query) (str "." val)))) - ((= typ "ident") (do (adv!) (list (quote ref) val))) + (let + ((s (cur-start)) (l (cur-line))) + (do + (adv!) + (hs-ast-wrap + (list (quote query) (str "." val)) + "selector" + s + (prev-end) + l + {})))) + ((= typ "ident") + (let + ((s (cur-start)) (l (cur-line))) + (do + (adv!) + (hs-ast-wrap + (list (quote ref) val) + "ref" + s + (prev-end) + l + {})))) ((= typ "paren-open") (do (adv!) @@ -239,7 +389,7 @@ (or (at-end?) (= (tp-type) "brace-close")) (do (when (= (tp-type) "brace-close") (adv!)) acc) (let - ((key (cond ((= (tp-type) "string") (let ((k (tp-val))) (do (adv!) k))) (true (let ((k (tp-val))) (do (adv!) k)))))) + ((key (cond ((= (tp-type) "string") (let ((k (tp-val))) (do (adv!) k))) ((= (tp-type) "bracket-open") (do (adv!) (let ((expr (parse-expr))) (do (when (= (tp-type) "bracket-close") (adv!)) (list (quote computed-key) expr))))) (true (let ((k (tp-val))) (do (adv!) k)))))) (let ((value (cond ((= (tp-type) "local") (let ((v (tp-val))) (do (adv!) (cond ((= v "true") true) ((= v "false") false) ((= v "null") nil) (true (list (quote ref) v)))))) ((= (tp-type) "colon") (do (adv!) (parse-expr))) (true (parse-expr))))) (do @@ -328,6 +478,7 @@ (let ((name val) (args (parse-call-args))) (cons (quote call) (cons (list (quote ref) name) args))))) + ((= typ "keyword") (do (adv!) (list (quote ref) val))) (true nil))))) (define parse-poss @@ -337,6 +488,17 @@ ((and (= (tp-type) "op") (= (tp-val) "'s")) (do (adv!) (parse-poss-tail obj))) ((= (tp-type) "class") (parse-prop-chain obj)) + ((= (tp-type) "dot") + (do + (adv!) + (let + ((typ2 (tp-type)) (val2 (tp-val))) + (if + (or (= typ2 "ident") (= typ2 "keyword")) + (do + (adv!) + (parse-poss (list (make-symbol ".") obj val2))) + obj)))) ((= (tp-type) "paren-open") (let ((args (parse-call-args))) @@ -463,7 +625,9 @@ (list (quote not) (list (quote eq-ignore-case) left right))) - (list (quote not) (list (quote =) left right))))))) + (list + (quote not) + (list (quote hs-id=) left right))))))) ((match-kw "empty") (list (quote empty?) left)) ((match-kw "less") (do @@ -495,7 +659,8 @@ (quote and) (list (quote >=) left lo) (list (quote <=) left hi))))) - ((match-kw "in") (list (quote in?) left (parse-expr))) + ((match-kw "in") + (list (quote in-bool?) left (parse-expr))) ((match-kw "really") (do (match-kw "equal") @@ -571,7 +736,8 @@ (let ((right (parse-expr))) (list (quote not) (list (quote =) left right)))))) - ((match-kw "in") (list (quote in?) left (parse-expr))) + ((match-kw "in") + (list (quote in-bool?) left (parse-expr))) ((match-kw "empty") (list (quote empty?) left)) ((match-kw "between") (let @@ -694,10 +860,20 @@ (adv!) (let ((target (parse-expr))) - (if - (and (list? left) (= (first left) (quote ref))) - (list (make-symbol ".") target (nth left 1)) - (list (quote of) left target))))) + (define + rebase-of-chain + (fn + (chain tgt) + (cond + ((and (list? chain) (= (first chain) (quote ref))) + (list (make-symbol ".") tgt (nth chain 1))) + ((and (list? chain) (= (str (first chain)) ".")) + (list + (make-symbol ".") + (rebase-of-chain (nth chain 1) tgt) + (nth chain 2))) + (true (list (quote of) chain tgt))))) + (rebase-of-chain left target)))) ((and (= typ "keyword") (= val "in")) (do (adv!) (list (quote in?) left (parse-expr)))) ((and (= typ "keyword") (= val "does")) @@ -801,13 +977,29 @@ (left) (cond ((match-kw "and") - (let - ((right (parse-collection (parse-cmp (parse-arith (parse-poss (parse-atom))))))) - (parse-logical (list (quote and) left right)))) + (do + (when + (and + (list? left) + (> (len left) 0) + (= (first left) (quote or))) + (error + "You must parenthesize logical operations with different operators")) + (let + ((right (parse-collection (parse-cmp (parse-arith (parse-poss (parse-atom))))))) + (parse-logical (list (quote and) left right))))) ((match-kw "or") - (let - ((right (parse-collection (parse-cmp (parse-arith (parse-poss (parse-atom))))))) - (parse-logical (list (quote or) left right)))) + (do + (when + (and + (list? left) + (> (len left) 0) + (= (first left) (quote and))) + (error + "You must parenthesize logical operations with different operators")) + (let + ((right (parse-collection (parse-cmp (parse-arith (parse-poss (parse-atom))))))) + (parse-logical (list (quote or) left right))))) (true left)))) (define parse-expr @@ -821,7 +1013,7 @@ (do (when (and - (number? left) + (or (number? left) (list? left)) (= (tp-type) "ident") (not (or @@ -891,7 +1083,7 @@ (collect-classes!)))) (collect-classes!) (let - ((tgt (if (match-kw "to") (parse-expr) (list (quote me))))) + ((tgt (if (match-kw "to") (parse-expr) (list (quote beingTold))))) (let ((when-clause (if (match-kw "when") (parse-expr) nil))) (if @@ -920,7 +1112,7 @@ (get (adv!) "value") (parse-expr)))) (let - ((tgt (if (match-kw "to") (parse-expr) (list (quote me))))) + ((tgt (if (match-kw "to") (parse-expr) (list (quote beingTold))))) (list (quote set-style) prop value tgt)))) ((= (tp-type) "brace-open") (do @@ -939,14 +1131,16 @@ ((prop (get (adv!) "value"))) (when (= (tp-type) "colon") (adv!)) (let - ((val (tp-val))) - (adv!) + ((val (if (and (= (tp-type) "ident") (= (tp-val) "$")) (do (adv!) (when (= (tp-type) "brace-open") (adv!)) (if (= (tp-type) "brace-close") (do (adv!) (if (= (tp-type) "brace-open") (do (adv!) (let ((inner (parse-expr))) (when (= (tp-type) "brace-close") (adv!)) inner)) "")) (let ((expr (parse-expr))) (when (= (tp-type) "brace-close") (adv!)) expr))) (get (adv!) "value")))) (set! pairs (cons (list prop val) pairs)) + (when + (and (= (tp-type) "op") (= (tp-val) ";")) + (adv!)) (collect-pairs!)))))) (collect-pairs!) (when (= (tp-type) "brace-close") (adv!)) (let - ((tgt (if (match-kw "to") (parse-expr) (list (quote me))))) + ((tgt (if (match-kw "to") (parse-expr) (list (quote beingTold))))) (list (quote set-styles) (reverse pairs) tgt))))) ((and (= (tp-type) "bracket-open") (> (len tokens) (+ p 1)) (= (get (nth tokens (+ p 1)) "type") "attr")) (do @@ -958,7 +1152,7 @@ ((attr-val (parse-expr))) (when (= (tp-type) "bracket-close") (adv!)) (let - ((tgt (parse-tgt-kw "to" (list (quote me))))) + ((tgt (parse-tgt-kw "to" (list (quote beingTold))))) (let ((when-clause (if (match-kw "when") (parse-expr) nil))) (if @@ -976,7 +1170,7 @@ (let ((attr-val (if (and (= (tp-type) "op") (= (tp-val) "=")) (do (adv!) (parse-expr)) ""))) (let - ((tgt (if (match-kw "to") (parse-expr) (list (quote me))))) + ((tgt (if (match-kw "to") (parse-expr) (list (quote beingTold))))) (let ((when-clause (if (match-kw "when") (parse-expr) nil))) (if @@ -996,7 +1190,9 @@ (let ((tgt (parse-expr))) (list (quote add-value) value tgt)) - nil)))))) + (error + (str + "Invalid 'add' syntax: expected a class (.foo), attribute, or expression with 'to'")))))))) (define parse-remove-cmd (fn @@ -1017,18 +1213,23 @@ (collect-classes!)))) (collect-classes!) (let - ((tgt (if (match-kw "from") (parse-expr) (list (quote me))))) - (if - (empty? extra-classes) - (list (quote remove-class) cls tgt) - (cons - (quote multi-remove-class) - (cons tgt (cons cls extra-classes))))))) + ((tgt (if (match-kw "from") (parse-expr) (list (quote beingTold))))) + (let + ((when-clause (if (match-kw "when") (parse-expr) nil))) + (if + (empty? extra-classes) + (if + when-clause + (list (quote remove-class-when) cls tgt when-clause) + (list (quote remove-class) cls tgt)) + (cons + (quote multi-remove-class) + (cons tgt (cons cls extra-classes)))))))) ((= (tp-type) "attr") (let ((attr-name (get (adv!) "value"))) (let - ((tgt (if (match-kw "from") (parse-expr) (list (quote me))))) + ((tgt (if (match-kw "from") (parse-expr) (list (quote beingTold))))) (list (quote remove-attr) attr-name tgt)))) ((and (= (tp-type) "bracket-open") (= (tp-val) "[")) (do @@ -1037,7 +1238,7 @@ (= (tp-type) "attr") (let ((attr-name (get (adv!) "value"))) - (match-kw "]") + (when (= (tp-type) "bracket-close") (adv!)) (let ((tgt (if (match-kw "from") (parse-expr) nil))) (list (quote remove-attr) attr-name tgt))) @@ -1090,7 +1291,7 @@ (let ((cls2 (do (let ((v (tp-val))) (adv!) v)))) (let - ((tgt (parse-tgt-kw "on" (list (quote me))))) + ((tgt (parse-tgt-kw "on" (list (quote beingTold))))) (list (quote toggle-between) cls1 cls2 tgt))) nil))) ((and (= (tp-type) "bracket-open") (> (len tokens) (+ p 1)) (= (get (nth tokens (+ p 1)) "type") "attr")) @@ -1115,7 +1316,7 @@ ((v2 (parse-expr))) (when (= (tp-type) "bracket-close") (adv!)) (let - ((tgt (parse-tgt-kw "on" (list (quote me))))) + ((tgt (parse-tgt-kw "on" (list (quote beingTold))))) (if (= n1 n2) (list @@ -1149,7 +1350,7 @@ (let ((extra-classes (collect-classes (list)))) (let - ((tgt (parse-tgt-kw "on" (list (quote me))))) + ((tgt (parse-tgt-kw "on" (list (quote beingTold))))) (cond ((> (len extra-classes) 0) (list @@ -1178,7 +1379,7 @@ (let ((prop (get (adv!) "value"))) (let - ((tgt (if (match-kw "of") (parse-expr) (list (quote me))))) + ((tgt (if (match-kw "of") (parse-expr) (list (quote beingTold))))) (if (match-kw "between") (let @@ -1249,7 +1450,7 @@ (let ((attr-name (get (adv!) "value"))) (let - ((tgt (if (match-kw "on") (parse-expr) (list (quote me))))) + ((tgt (if (match-kw "on") (parse-expr) (list (quote beingTold))))) (if (match-kw "between") (let @@ -1274,7 +1475,7 @@ ((attr-val (parse-expr))) (when (= (tp-type) "bracket-close") (adv!)) (let - ((tgt (parse-tgt-kw "on" (list (quote me))))) + ((tgt (parse-tgt-kw "on" (list (quote beingTold))))) (list (quote toggle-attr-val) attr-name attr-val tgt)))))) ((and (= (tp-type) "keyword") (= (tp-val) "my")) (do @@ -1340,20 +1541,57 @@ ((tgt (nth expr 1)) (cls (nth expr 2))) (list (quote toggle-class) cls tgt))) (true nil))))) + ((and (= (tp-type) "ident") (> (len (tp-val)) 0) (= (substring (tp-val) 0 1) "$")) + (let + ((var-name (tp-val))) + (adv!) + (if + (match-kw "between") + (let + ((val1 (parse-atom))) + (define + collect-vals + (fn + (acc) + (if + (or + (= (tp-type) "comma") + (and + (= (tp-type) "keyword") + (= (tp-val) "and"))) + (do + (when (= (tp-type) "comma") (adv!)) + (when + (and + (= (tp-type) "keyword") + (= (tp-val) "and")) + (adv!)) + (collect-vals (append acc (list (parse-atom))))) + acc))) + (let + ((more-vals (collect-vals (list)))) + (list + (quote toggle-var-cycle) + var-name + (cons val1 more-vals)))) + nil))) (true nil)))) (define parse-set-cmd (fn () (let - ((tgt-raw (cond ((and (= (tp-type) "ident") (or (= (tp-val) "element") (= (tp-val) "global") (= (tp-val) "local"))) (do (adv!) (parse-expr))) (true (parse-expr))))) + ((tgt-raw (cond ((and (= (tp-type) "ident") (or (= (tp-val) "global") (= (tp-val) "local"))) (do (adv!) (parse-expr))) ((and (= (tp-type) "ident") (= (tp-val) "element")) (do (adv!) (if (and (= (tp-type) "op") (= (tp-val) "'s")) (parse-poss (list (quote ref) "element")) (parse-expr)))) (true (parse-expr))))) (let ((tgt (if (= (tp-type) "attr") (let ((attr-name (get (adv!) "value"))) (list (quote attr) attr-name tgt-raw)) tgt-raw))) (cond ((match-kw "to") (let ((value (parse-expr))) - (list (quote set!) tgt value))) + (if + (and (list? tgt) (= (first tgt) (quote query))) + (list (quote set-el!) tgt value) + (list (quote set!) tgt value)))) ((match-kw "on") (let ((target (parse-expr))) @@ -1417,7 +1655,7 @@ (cond ((match-kw "for") (let - ((event-name (tp-val))) + ((event-name (do (when (or (= (tp-val) "a") (= (tp-val) "an") (= (tp-val) "the")) (adv!)) (tp-val)))) (adv!) (let ((destructure (if (= (tp-type) "paren-open") (let ((_ (adv!))) (define collect-dnames (fn (acc) (cond ((or (= (tp-type) "paren-close") (at-end?)) (do (if (= (tp-type) "paren-close") (adv!) nil) acc)) ((= (tp-type) "comma") (do (adv!) (collect-dnames acc))) (true (let ((name (tp-val))) (adv!) (collect-dnames (append acc (list name)))))))) (collect-dnames (list))) nil))) @@ -1502,7 +1740,7 @@ (let ((dtl (if (= (tp-type) "paren-open") (parse-detail-dict) nil))) (let - ((tgt (parse-tgt-kw "to" (list (quote me))))) + ((tgt (parse-tgt-kw "to" (list (quote beingTold))))) (if dtl (list (quote send) name dtl tgt) @@ -1516,12 +1754,26 @@ (let ((dtl (if (= (tp-type) "paren-open") (parse-detail-dict) nil))) (let - ((tgt (parse-tgt-kw "on" (list (quote me))))) + ((tgt (parse-tgt-kw "on" (list (quote beingTold))))) (if dtl (list (quote trigger) name dtl tgt) (list (quote trigger) name tgt))))))) - (define parse-log-cmd (fn () (list (quote log) (parse-expr)))) + (define + parse-log-cmd + (fn + () + (define + collect-args + (fn + (acc) + (if + (= (tp-type) "comma") + (do + (adv!) + (collect-args (append acc (list (parse-expr))))) + acc))) + (cons (quote log) (collect-args (list (parse-expr)))))) (define parse-inc-cmd (fn @@ -1555,7 +1807,7 @@ (fn () (let - ((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show"))) (list (quote me))) (true (parse-expr))))) + ((tgt (cond ((at-end?) (list (quote beingTold))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show") (= (tp-val) "on"))) (list (quote beingTold))) (true (parse-expr))))) (let ((strategy (if (match-kw "with") (if (at-end?) "display" (let ((s (tp-val))) (do (adv!) (cond ((at-end?) s) ((= (tp-type) "colon") (do (adv!) (let ((v (tp-val))) (do (adv!) (str s ":" v))))) ((= (tp-type) "local") (let ((v (tp-val))) (do (adv!) (str s ":" v)))) (true s))))) "display"))) (let @@ -1566,7 +1818,7 @@ (fn () (let - ((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show"))) (list (quote me))) (true (parse-expr))))) + ((tgt (cond ((at-end?) (list (quote beingTold))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show") (= (tp-val) "on"))) (list (quote beingTold))) (true (parse-expr))))) (let ((strategy (if (match-kw "with") (if (at-end?) "display" (let ((s (tp-val))) (do (adv!) (cond ((at-end?) s) ((= (tp-type) "colon") (do (adv!) (let ((v (tp-val))) (do (adv!) (str s ":" v))))) ((= (tp-type) "local") (let ((v (tp-val))) (do (adv!) (str s ":" v)))) (true s))))) "display"))) (let @@ -1577,7 +1829,7 @@ (fn () (let - ((tgt (cond ((and (= (tp-type) "ident") (= (tp-val) "element")) (do (adv!) (parse-atom))) ((and (= (tp-type) "keyword") (= (tp-val) "its")) (do (adv!) (list (quote ref) "it"))) ((= (tp-type) "id") (parse-atom)) ((= (tp-type) "class") (parse-atom)) ((= (tp-type) "selector") (parse-atom)) (true nil)))) + ((tgt (cond ((and (= (tp-type) "ident") (= (tp-val) "element")) (do (adv!) (parse-atom))) ((and (= (tp-type) "keyword") (= (tp-val) "its")) (do (adv!) (list (quote ref) "it"))) ((= (tp-type) "id") (parse-atom)) ((= (tp-type) "class") (parse-atom)) ((= (tp-type) "selector") (parse-atom)) ((= (tp-val) "the") (parse-atom)) (true nil)))) (define parse-one-transition (fn @@ -1592,7 +1844,7 @@ ((from-val (if (match-kw "from") (let ((v (parse-atom))) (if (and v (= (tp-type) "ident") (not (hs-keyword? (tp-val)))) (let ((unit (get (adv!) "value"))) (list (quote string-postfix) v unit)) v)) nil))) (expect-kw! "to") (let - ((value (let ((v (parse-atom))) (if (and v (= (tp-type) "ident") (not (hs-keyword? (tp-val)))) (let ((unit (get (adv!) "value"))) (list (quote string-postfix) v unit)) v)))) + ((value (if (and (= (tp-type) "ident") (= (tp-val) "initial")) (do (adv!) "initial") (let ((v (parse-atom))) (if (and v (= (tp-type) "ident") (not (hs-keyword? (tp-val)))) (let ((unit (get (adv!) "value"))) (list (quote string-postfix) v unit)) v))))) (let ((dur (if (match-kw "over") (let ((v (parse-atom))) (if (and (number? v) (= (tp-type) "ident") (not (hs-keyword? (tp-val)))) (let ((unit (get (adv!) "value"))) (list (quote string-postfix) v unit)) v)) nil))) (let @@ -1650,7 +1902,7 @@ (list (quote for) "it" collection body))))) (true (let - ((mode (cond ((match-kw "forever") (list (quote forever))) ((match-kw "while") (list (quote while) (parse-expr))) ((match-kw "until") (list (quote until) (parse-expr))) (true (let ((n (parse-expr))) (if (match-kw "times") (list (quote times) n) (list (quote forever)))))))) + ((mode (cond ((match-kw "forever") (list (quote forever))) ((match-kw "while") (list (quote while) (parse-expr))) ((match-kw "until") (list (quote until) (parse-expr))) (true (if (or (= (tp-type) "number") (= (tp-type) "ident") (= (tp-type) "paren-open")) (let ((n (parse-expr))) (if (match-kw "times") (list (quote times) n) (list (quote forever)))) (list (quote forever))))))) (let ((body (do (match-kw "then") (parse-cmd-list)))) (cond @@ -1682,7 +1934,7 @@ ((url (if (and (= (tp-type) "keyword") (= (tp-val) "from")) (do (adv!) (parse-arith (parse-poss (parse-atom)))) nil))) (list (quote fetch-gql) gql-source url)))) (let - ((url-atom (if (and (= (tp-type) "op") (= (tp-val) "/")) (do (adv!) (let ((path-parts (list "/"))) (define read-path (fn () (when (and (not (at-end?)) (or (= (tp-type) "ident") (= (tp-type) "op") (= (tp-type) "dot") (= (tp-type) "number"))) (append! path-parts (tp-val)) (adv!) (read-path)))) (read-path) (join "" path-parts))) (parse-atom)))) + ((url-atom (if (and (= (tp-type) "op") (= (tp-val) "/")) (do (adv!) (let ((path-parts (list "/"))) (define read-path (fn () (when (and (not (at-end?)) (or (and (= (tp-type) "ident") (not (string-contains? (tp-val) "'"))) (= (tp-type) "op") (= (tp-type) "dot") (= (tp-type) "number"))) (append! path-parts (tp-val)) (adv!) (read-path)))) (read-path) (join "" path-parts))) (parse-atom)))) (let ((url (if (nil? url-atom) url-atom (parse-arith (parse-poss url-atom))))) (let @@ -1698,7 +1950,9 @@ ((fmt-after (if (and (not fmt-before) (match-kw "as")) (do (when (and (or (= (tp-type) "ident") (= (tp-type) "keyword")) (or (= (tp-val) "an") (= (tp-val) "a"))) (adv!)) (let ((f (tp-val))) (adv!) f)) nil))) (let ((fmt (or fmt-before fmt-after "text"))) - (list (quote fetch) url fmt))))))))) + (let + ((do-not-throw (cond ((and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "do")) (do (adv!) (if (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "not")) (do (adv!) (if (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "throw")) (do (adv!) true) false)) false))) ((and (= (tp-type) "ident") (= (tp-val) "don't")) (do (adv!) (if (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "throw")) (do (adv!) true) false))) (true false)))) + (list (quote fetch) url fmt do-not-throw)))))))))) (define parse-call-args (fn @@ -2014,12 +2268,47 @@ (= val "%"))) (and (= typ "keyword") (= val "mod"))) (do + (when + (and (list? left) (> (len left) 0)) + (let + ((left-op (first left))) + (when + (or + (and + (or (= left-op (quote +)) (= left-op (quote -))) + (or + (= val "*") + (= val "/") + (= val "%") + (= val "mod"))) + (and + (or + (= left-op (quote *)) + (= left-op (quote /)) + (= left-op (make-symbol "%"))) + (or (= val "+") (= val "-")))) + (error + "You must parenthesize math operations with different operators")))) (adv!) (let ((op (cond ((= val "+") (quote +)) ((= val "-") (quote -)) ((= val "*") (quote *)) ((= val "/") (quote /)) ((or (= val "%") (= val "mod")) (make-symbol "%"))))) (let ((right (let ((a (parse-atom))) (if (nil? a) a (parse-poss a))))) - (parse-arith (list op left right))))) + (let + ((lhs-start (if (and (dict? left) (get left :hs-ast)) (get left :start) 0)) + (lhs-line + (if + (and (dict? left) (get left :hs-ast)) + (get left :line) + 1))) + (parse-arith + (hs-ast-wrap + (list op left right) + "arith" + lhs-start + (prev-end) + lhs-line + {:rhs right :lhs left})))))) left)))) (define parse-the-expr @@ -2034,21 +2323,21 @@ (if (match-kw "of") (list (quote style) val (parse-expr)) - (list (quote style) val (list (quote me)))))) + (list (quote style) val (list (quote beingTold)))))) ((= typ "attr") (do (adv!) (if (match-kw "of") (list (quote attr) val (parse-expr)) - (list (quote attr) val (list (quote me)))))) + (list (quote attr) val (list (quote beingTold)))))) ((= typ "class") (do (adv!) (if (match-kw "of") (list (quote has-class?) (parse-expr) val) - (list (quote has-class?) (list (quote me)) val)))) + (list (quote has-class?) (list (quote beingTold)) val)))) ((= typ "selector") (do (adv!) @@ -2196,13 +2485,15 @@ () (let ((tgt (parse-expr))) - (list (quote measure) (if (nil? tgt) (list (quote me)) tgt))))) + (list + (quote measure) + (if (nil? tgt) (list (quote beingTold)) tgt))))) (define parse-scroll-cmd (fn () (let - ((tgt (if (or (at-end?) (and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end")))) (list (quote me)) (parse-expr)))) + ((tgt (if (or (at-end?) (and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end")))) (list (quote beingTold)) (parse-expr)))) (let ((pos (cond ((match-kw "top") "top") ((match-kw "bottom") "bottom") ((match-kw "left") "left") ((match-kw "right") "right") (true "top")))) (list (quote scroll!) tgt pos))))) @@ -2211,14 +2502,14 @@ (fn () (let - ((tgt (if (or (at-end?) (and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end")))) (list (quote me)) (parse-expr)))) + ((tgt (if (or (at-end?) (and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end")))) (list (quote beingTold)) (parse-expr)))) (list (quote select!) tgt)))) (define parse-reset-cmd (fn () (let - ((tgt (if (or (at-end?) (and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end")))) (list (quote me)) (parse-expr)))) + ((tgt (if (or (at-end?) (and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end")))) (list (quote beingTold)) (parse-expr)))) (list (quote reset!) tgt)))) (define parse-default-cmd @@ -2233,7 +2524,7 @@ (fn () (let - ((mode (cond ((match-kw "the") (do (match-kw "event") (when (and (= (tp-type) "op") (= (tp-val) "'s")) (adv!)) "the-event")) ((or (match-kw "default") (and (= (tp-val) "default") (do (adv!) true))) "default") ((or (match-kw "bubbling") (and (= (tp-val) "bubbling") (do (adv!) true))) "bubbling") (true "all")))) + ((mode (cond ((match-kw "the") (do (match-kw "event") (when (and (= (tp-type) "op") (= (tp-val) "'s")) (adv!)) (if (= (tp-val) "bubbling") (do (adv!) "bubbling") "the-event"))) ((or (match-kw "default") (and (= (tp-val) "default") (do (adv!) true))) "default") ((or (match-kw "bubbling") (and (= (tp-val) "bubbling") (do (adv!) true))) "bubbling") (true "all")))) (list (quote halt!) mode)))) (define parse-param-list @@ -2243,7 +2534,7 @@ (fn () (let - ((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote me))) (true (parse-expr))))) + ((tgt (cond ((at-end?) (list (quote beingTold))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote beingTold))) (true (parse-expr))))) (list (quote focus!) tgt)))) (define parse-feat-body @@ -2256,7 +2547,8 @@ (if (or (at-end?) - (and (= (tp-type) "keyword") (= (tp-val) "end"))) + (and (= (tp-type) "keyword") (= (tp-val) "end")) + (and (= (tp-type) "keyword") (= (tp-val) "behavior"))) acc (let ((feat (parse-feat))) @@ -2357,7 +2649,7 @@ (fn () (let - ((target (cond ((at-end?) (list (quote ref) "me")) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote ref) "me")) (true (parse-expr))))) + ((target (cond ((at-end?) (list (quote beingTold))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote beingTold))) (true (parse-expr))))) (list (quote empty-target) target)))) (define parse-swap-cmd @@ -2382,15 +2674,42 @@ (fn () (let - ((target (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote me))) (true (parse-expr))))) + ((target (cond ((at-end?) (list (quote beingTold))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote beingTold))) (true (parse-expr))))) (list (quote open-element) target)))) (define parse-close-cmd (fn () (let - ((target (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote me))) (true (parse-expr))))) + ((target (cond ((at-end?) (list (quote beingTold))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote beingTold))) (true (parse-expr))))) (list (quote close-element) target)))) + (define + parse-js-block + (fn + () + (let + ((params (if (= (tp-type) "paren-open") (do (adv!) (define collect-params! (fn (acc) (cond ((or (at-end?) (= (tp-type) "paren-close")) (do (when (= (tp-type) "paren-close") (adv!)) acc)) ((= (tp-type) "comma") (do (adv!) (collect-params! acc))) (true (let ((pname (tp-val))) (do (adv!) (collect-params! (append acc pname)))))))) (collect-params! (list))) (list)))) + (let + ((js-start (cur-start))) + (define + skip-to-end! + (fn + () + (if + (or + (at-end?) + (and (= (tp-type) "keyword") (= (tp-val) "end"))) + nil + (do (adv!) (skip-to-end!))))) + (skip-to-end!) + (let + ((js-end (cur-start))) + (let + ((js-src (substring src js-start js-end))) + (when + (and (= (tp-type) "keyword") (= (tp-val) "end")) + (adv!)) + (list (quote js-block) params js-src))))))) (define parse-cmd (fn @@ -2419,7 +2738,21 @@ ((and (= typ "keyword") (= val "put")) (do (adv!) (parse-put-cmd))) ((and (= typ "keyword") (= val "if")) - (do (adv!) (parse-if-cmd))) + (let + ((s (cur-start)) (l (cur-line))) + (do + (adv!) + (let + ((r (parse-if-cmd))) + (let + ((tb (if (and (list? r) (> (len r) 2)) (nth r 2) nil))) + (hs-ast-wrap + r + "if" + s + (prev-end) + l + (if tb {:true-branch (if (and (list? tb) (= (first tb) (quote do))) (nth tb 1) tb)} {}))))))) ((and (= typ "keyword") (= val "wait")) (do (adv!) (parse-wait-cmd))) ((and (= typ "keyword") (= val "send")) @@ -2427,7 +2760,17 @@ ((and (= typ "keyword") (= val "trigger")) (do (adv!) (parse-trigger-cmd))) ((and (= typ "keyword") (= val "log")) - (do (adv!) (parse-log-cmd))) + (let + ((s (cur-start)) (l (cur-line))) + (do + (adv!) + (hs-ast-wrap + (parse-log-cmd) + "cmd" + s + (prev-end) + l + {})))) ((and (= typ "keyword") (= val "increment")) (do (adv!) (parse-inc-cmd))) ((and (= typ "keyword") (= val "decrement")) @@ -2455,7 +2798,14 @@ ((and (= typ "keyword") (= val "answer")) (do (adv!) (parse-answer-cmd))) ((and (= typ "keyword") (= val "settle")) - (do (adv!) (list (quote settle)))) + (do + (adv!) + (let + ((tgt (cond ((at-end?) nil) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "on"))) nil) (true (parse-expr))))) + (if + (nil? tgt) + (list (quote settle)) + (list (quote settle) tgt))))) ((and (= typ "keyword") (= val "go")) (do (adv!) (parse-go-cmd))) ((and (= typ "keyword") (= val "return")) @@ -2467,7 +2817,17 @@ ((and (= typ "keyword") (= val "tell")) (do (adv!) (parse-tell-cmd))) ((and (= typ "keyword") (= val "for")) - (do (adv!) (parse-for-cmd))) + (let + ((s (cur-start)) (l (cur-line))) + (do + (adv!) + (hs-ast-wrap + (parse-for-cmd) + "cmd" + s + (prev-end) + l + {})))) ((and (= typ "keyword") (= val "make")) (do (adv!) (parse-make-cmd))) ((and (= typ "keyword") (= val "install")) @@ -2506,7 +2866,42 @@ (do (adv!) (list (quote continue)))) ((and (= typ "keyword") (or (= val "exit") (= val "halt"))) (do (adv!) (list (quote exit)))) - (true (parse-expr)))))) + ((and (= typ "keyword") (= val "js")) + (do (adv!) (parse-js-block))) + ((and (= typ "keyword") (= val "start")) + (do + (adv!) + (expect-kw! "view") + (expect-kw! "transition") + (let + ((using (if (match-kw "using") (parse-expr) nil))) + (match-kw "then") + (let + ((body (parse-cmd-list))) + (match-kw "end") + (list (quote view-transition!) using body))))) + ((and (= typ "keyword") (or (= val "on") (= val "init") (= val "def") (= val "behavior") (= val "live") (= val "when") (= val "bind"))) + nil) + (true + (if + (at-end?) + nil + (let + ((expr (parse-expr))) + (if + (and + (list? expr) + (not (= (tp-type) "paren-close")) + (let + ((h (first expr))) + (or + (= h (quote +)) + (= h (quote -)) + (= h (quote *)) + (= h (quote /)) + (= h (make-symbol "%"))))) + (error "Pseudo-commands must be function calls") + expr)))))))) (define parse-cmd-list (fn @@ -2561,103 +2956,178 @@ (= v "close") (= v "pick") (= v "ask") - (= v "answer")))) + (= v "answer") + (= v "js") + (= v "start")))) (define cl-collect (fn (acc) - (let - ((cmd (parse-cmd))) - (if - (nil? cmd) - acc - (let - ((acc2 (append acc (list cmd)))) - (cond - ((match-kw "unless") - (let - ((cnd (parse-expr))) - (cl-collect - (append - acc - (list - (list (quote if) (list (quote no) cnd) cmd)))))) - ((match-kw "then") - (cl-collect (append acc2 (list (quote __then__))))) - ((or (and (not (at-end?)) (= (tp-type) "keyword") (cmd-kw? (tp-val))) (= (tp-type) "paren-open")) - (cl-collect acc2)) - (true acc2))))))) + (do + (when + (and (= (tp-type) "keyword") (= (tp-val) "then")) + (adv!)) + (let + ((cmd (parse-cmd))) + (if + (nil? cmd) + acc + (let + ((acc2 (append acc (list cmd)))) + (cond + ((match-kw "unless") + (let + ((cnd (parse-expr))) + (cl-collect + (append + acc + (list + (list + (quote if) + (list (quote no) cnd) + cmd)))))) + ((match-kw "then") + (cl-collect (append acc2 (list (quote __then__))))) + ((or (and (not (at-end?)) (= (tp-type) "keyword") (cmd-kw? (tp-val))) (= (tp-type) "paren-open")) + (cl-collect acc2)) + (true acc2)))))))) (let ((cmds (cl-collect (list)))) - (cond - ((= (len cmds) 0) nil) - ((= (len cmds) 1) (first cmds)) - (true - (cons - (quote do) - (filter (fn (c) (not (= c (quote __then__)))) cmds))))))) + (define + link-next-cmds + (fn + (cmds-list) + (define + loop + (fn + (i) + (when + (< i (- (len cmds-list) 1)) + (let + ((cur-node (nth cmds-list i)) + (nxt-node (nth cmds-list (+ i 1)))) + (when + (and (dict? cur-node) (get cur-node :hs-ast)) + (dict-set! (get cur-node :fields) "next" nxt-node))) + (loop (+ i 1))))) + (loop 0) + cmds-list)) + (let + ((linked (if hs-span-mode (link-next-cmds cmds) cmds))) + (cond + ((= (len linked) 0) nil) + ((= (len linked) 1) (first linked)) + (true + (cons + (quote do) + (filter (fn (c) (not (= c (quote __then__)))) linked)))))))) (define parse-on-feat (fn () (let - ((every? (match-kw "every"))) + ((first? (match-kw "first"))) (let ((event-name (parse-compound-event-name))) (let - ((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil))) + ((count-filter (let ((mn nil) (mx nil)) (when first? (do (set! mn 1) (set! mx 1))) (when (= (tp-type) "number") (let ((n (parse-number (tp-val)))) (do (adv!) (set! mn n) (cond ((match-kw "to") (cond ((= (tp-type) "number") (let ((mv (parse-number (tp-val)))) (do (adv!) (set! mx mv)))) (true (set! mx n)))) ((match-kw "and") (cond ((match-kw "on") (set! mx -1)) (true (set! mx n)))) (true (set! mx n)))))) (if mn (dict "min" mn "max" mx) nil)))) (let - ((source (if (match-kw "from") (parse-expr) nil))) + ((of-filter (when (and (= event-name "mutation") (match-kw "of")) (cond ((and (= (tp-type) "ident") (or (= (tp-val) "attributes") (= (tp-val) "childList") (= (tp-val) "characterData"))) (let ((nm (tp-val))) (do (adv!) (dict "type" nm)))) ((= (tp-type) "attr") (let ((attrs (list (tp-val)))) (do (adv!) (define collect-or! (fn () (when (match-kw "or") (cond ((= (tp-type) "attr") (do (set! attrs (append attrs (list (tp-val)))) (adv!) (collect-or!))) (true (set! p (- p 1))))))) (collect-or!) (dict "type" "attrs" "attrs" attrs)))) (true nil))))) (let - ((h-margin nil) (h-threshold nil)) - (define - consume-having! - (fn - () - (cond - ((and (= (tp-type) "ident") (= (tp-val) "having")) - (do - (adv!) - (cond - ((and (= (tp-type) "ident") (= (tp-val) "margin")) - (do - (adv!) - (set! h-margin (parse-expr)) - (consume-having!))) - ((and (= (tp-type) "ident") (= (tp-val) "threshold")) - (do - (adv!) - (set! h-threshold (parse-expr)) - (consume-having!))) - (true nil)))) - (true nil)))) - (consume-having!) + ((event-vars (if (= (tp-type) "paren-open") (let ((saved-p p)) (do (adv!) (if (= (tp-type) "keyword") (do (set! p saved-p) (list)) (do (define ev-coll (fn () (cond ((or (= (tp-type) "paren-close") (= (tp-type) "eof")) (do (when (= (tp-type) "paren-close") (adv!)) (list))) ((or (= (tp-type) "ident") (= (tp-type) "keyword")) (let ((nm (tp-val))) (adv!) (cons nm (ev-coll)))) (true (do (adv!) (ev-coll)))))) (ev-coll))))) (list)))) (let - ((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil))) + ((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil))) (let - ((body (parse-cmd-list))) - (let - ((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil)) - (finally-clause - (if (match-kw "finally") (parse-cmd-list) nil))) - (match-kw "end") - (let - ((parts (list (quote on) event-name))) - (let - ((parts (if every? (append parts (list :every true)) parts))) + ((elsewhere? (cond ((match-kw "elsewhere") true) ((and (= (tp-type) "keyword") (= (tp-val) "from") (let ((nxt (if (< (+ p 1) tok-len) (nth tokens (+ p 1)) nil))) (and nxt (= (get nxt "type") "keyword") (= (get nxt "value") "elsewhere")))) (do (adv!) (adv!) true)) (true false))) + (source + (if + (match-kw "from") + (parse-collection + (parse-cmp + (parse-arith (parse-poss (parse-atom))))) + nil))) + (define + collect-ors! + (fn + (acc) + (if + (match-kw "or") (let - ((parts (if flt (append parts (list :filter flt)) parts))) + ((or-evt (parse-compound-event-name)) + (or-src + (if (match-kw "from") (parse-expr) nil))) + (collect-ors! + (append acc (list (list or-evt or-src))))) + acc))) + (define or-sources (collect-ors! (list))) + (let + ((h-margin nil) (h-threshold nil)) + (define + consume-having! + (fn + () + (cond + ((and (= (tp-type) "ident") (= (tp-val) "having")) + (do + (adv!) + (cond + ((and (= (tp-type) "ident") (= (tp-val) "margin")) + (do + (adv!) + (set! h-margin (parse-expr)) + (consume-having!))) + ((and (= (tp-type) "ident") (= (tp-val) "threshold")) + (do + (adv!) + (set! h-threshold (parse-expr)) + (consume-having!))) + (true nil)))) + (true nil)))) + (consume-having!) + (when + (and + (= (tp-type) "keyword") + (= (tp-val) "queue")) + (do (adv!) (adv!))) + (let + ((every? (match-kw "every"))) + (let + ((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil))) + (let + ((body (parse-cmd-list))) (let - ((parts (if source (append parts (list :from source)) parts))) + ((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil)) + (finally-clause + (if + (match-kw "finally") + (parse-cmd-list) + nil))) + (match-kw "end") (let - ((parts (if having (append parts (list :having having)) parts))) + ((parts (list (quote on) event-name))) (let - ((parts (if catch-clause (append parts (list :catch catch-clause)) parts))) + ((parts (if every? (append parts (list :every true)) parts))) (let - ((parts (if finally-clause (append parts (list :finally finally-clause)) parts))) + ((parts (if flt (append parts (list :filter flt)) parts))) (let - ((parts (append parts (list body)))) - parts)))))))))))))))))) + ((parts (if elsewhere? (append parts (list :elsewhere true)) parts))) + (let + ((parts (if source (append parts (list :from source)) parts))) + (let + ((parts (if (> (len or-sources) 0) (append parts (list :or-sources or-sources)) parts))) + (let + ((parts (if count-filter (append parts (list :count-filter count-filter)) parts))) + (let + ((parts (if of-filter (append parts (list :of-filter of-filter)) parts))) + (let + ((parts (if having (append parts (list :having having)) parts))) + (let + ((parts (if catch-clause (append parts (list :catch catch-clause)) parts))) + (let + ((parts (if finally-clause (append parts (list :finally finally-clause)) parts))) + (let + ((parts (append parts (list (if (> (len event-vars) 0) (cons (quote do) (append (map (fn (nm) (list (quote ref) nm)) event-vars) (if (and (list? body) (= (first body) (quote do))) (rest body) (list body)))) body))))) + parts)))))))))))))))))))))))))) (define parse-init-feat (fn @@ -2673,13 +3143,17 @@ (define plf-skip (fn - () + (depth) (cond ((at-end?) nil) - ((and (= (tp-type) "keyword") (or (= (tp-val) "end") (= (tp-val) "on") (= (tp-val) "init") (= (tp-val) "def") (= (tp-val) "behavior") (= (tp-val) "live") (= (tp-val) "when"))) + ((and (= (tp-type) "keyword") (or (= (tp-val) "on") (= (tp-val) "init") (= (tp-val) "def") (= (tp-val) "behavior") (= (tp-val) "live") (= (tp-val) "when"))) nil) - (true (do (adv!) (plf-skip)))))) - (plf-skip) + ((and (= (tp-type) "keyword") (= (tp-val) "end")) + (if (> depth 0) (do (adv!) (plf-skip (- depth 1))) nil)) + ((and (= (tp-type) "keyword") (or (= (tp-val) "if") (= (tp-val) "repeat"))) + (do (adv!) (plf-skip (+ depth 1)))) + (true (do (adv!) (plf-skip depth)))))) + (plf-skip 0) (match-kw "end") (list (quote live-no-op)))) (define @@ -2689,15 +3163,20 @@ (define pwf-skip (fn - () + (depth) (cond ((at-end?) nil) - ((and (= (tp-type) "keyword") (or (= (tp-val) "end") (= (tp-val) "on") (= (tp-val) "init") (= (tp-val) "def") (= (tp-val) "behavior") (= (tp-val) "live") (= (tp-val) "when"))) + ((and (= (tp-type) "keyword") (or (= (tp-val) "on") (= (tp-val) "init") (= (tp-val) "def") (= (tp-val) "behavior") (= (tp-val) "live") (= (tp-val) "when"))) nil) - (true (do (adv!) (pwf-skip)))))) + ((and (= (tp-type) "keyword") (= (tp-val) "end")) + (if (> depth 0) (do (adv!) (pwf-skip (- depth 1))) nil)) + ((and (= (tp-type) "keyword") (or (= (tp-val) "if") (= (tp-val) "repeat"))) + (do (adv!) (pwf-skip (+ depth 1)))) + (true (do (adv!) (pwf-skip depth)))))) (if (or (= (tp-type) "hat") + (= (tp-type) "local") (and (= (tp-type) "keyword") (= (tp-val) "dom"))) (let ((expr (parse-expr))) @@ -2709,10 +3188,78 @@ (match-kw "end") (list (quote when-changes) expr body))) (do - (pwf-skip) + (pwf-skip 0) (match-kw "end") (list (quote when-feat-no-op))))) - (do (pwf-skip) (match-kw "end") (list (quote when-feat-no-op)))))) + (do + (pwf-skip 0) + (match-kw "end") + (list (quote when-feat-no-op)))))) + (define + parse-bind-feat + (fn + () + (let + ((lhs (parse-cmp (parse-arith (parse-poss (parse-atom)))))) + (cond + ((or (match-kw "to") (match-kw "with")) + (let + ((rhs (parse-cmp (parse-arith (parse-poss (parse-atom)))))) + (match-kw "end") + (list (quote bind-feat) lhs rhs))) + ((match-kw "and") + (let + ((rhs (parse-cmp (parse-arith (parse-poss (parse-atom)))))) + (match-kw "end") + (list (quote bind-feat) lhs rhs))) + (true (do (match-kw "end") (list (quote bind-feat) lhs nil))))))) + (define + parse-socket-feat + (fn + () + (let + ((first-seg (tp-val))) + (do + (adv!) + (define + collect-dots! + (fn + (acc) + (if + (= (tp-type) "class") + (let + ((seg (tp-val))) + (do (adv!) (collect-dots! (append acc (list seg))))) + acc))) + (let + ((name-path (collect-dots! (list first-seg)))) + (let + ((url (parse-arith (parse-poss (parse-atom))))) + (let + ((timeout (if (match-kw "with") (do (when (and (or (= (tp-type) "ident") (= (tp-type) "keyword")) (= (tp-val) "timeout")) (adv!)) (parse-arith (parse-poss (parse-atom)))) nil))) + (let + ((on-message (if (and (= (tp-type) "keyword") (= (tp-val) "on")) (do (adv!) (when (and (or (= (tp-type) "ident") (= (tp-type) "keyword")) (= (tp-val) "message")) (do (adv!) (let ((json? (if (match-kw "as") (do (when (and (or (= (tp-type) "ident") (= (tp-type) "keyword")) (= (tp-val) "JSON")) (adv!)) true) false))) (let ((body (parse-cmd-list))) (list (quote on-message) json? body)))))) nil))) + (do + (match-kw "end") + (list (quote socket) name-path url timeout on-message)))))))))) + (define + parse-feat-ctx + (fn + () + {:adv! adv! + :tp-val tp-val + :tp-type tp-type + :at-end? at-end? + :parse-cmd-list parse-cmd-list + :parse-expr parse-expr + :parse-on-feat parse-on-feat + :parse-init-feat parse-init-feat + :parse-def-feat parse-def-feat + :parse-behavior-feat parse-behavior-feat + :parse-live-feat parse-live-feat + :parse-when-feat parse-when-feat + :parse-bind-feat parse-bind-feat + :parse-socket-feat parse-socket-feat})) (define parse-feat (fn @@ -2726,14 +3273,40 @@ (let ((inner (parse-feat))) (if (= (tp-type) "paren-close") (adv!) nil) - inner))) - ((= val "on") (do (adv!) (parse-on-feat))) - ((= val "init") (do (adv!) (parse-init-feat))) - ((= val "def") (do (adv!) (parse-def-feat))) - ((= val "behavior") (do (adv!) (parse-behavior-feat))) - ((= val "live") (do (adv!) (parse-live-feat))) - ((= val "when") (do (adv!) (parse-when-feat))) - (true (parse-cmd-list)))))) + (if + (and + inner + (or + (and + (= (tp-type) "ident") + (not + (or + (= (tp-val) "then") + (= (tp-val) "end") + (= (tp-val) "else") + (= (tp-val) "otherwise")))) + (and (= (tp-type) "op") (= (tp-val) "%")))) + (let + ((unit (tp-val))) + (do (adv!) (list (quote string-postfix) inner unit))) + inner)))) + (true + (let + ((reg-fn (dict-get _hs-feature-registry val))) + (if + reg-fn + (reg-fn (parse-feat-ctx)) + (if + (= (tp-type) "keyword") + (parse-cmd-list) + (let + ((saved-p p)) + (let + ((expr (guard (_e (true nil)) (parse-expr)))) + (if + (and expr (at-end?)) + expr + (do (set! p saved-p) (parse-cmd-list))))))))))))) (define coll-feats (fn @@ -2743,7 +3316,19 @@ acc (let ((feat (parse-feat))) - (if (nil? feat) acc (coll-feats (append acc (list feat)))))))) + (if + (nil? feat) + (if + (at-end?) + acc + (error + (str + "Parse error: Unexpected token '" + (tp-val) + "' (line " + (get (nth tokens p) "line") + ")"))) + (coll-feats (append acc (list feat)))))))) (let ((features (coll-feats (list)))) (if @@ -2751,4 +3336,46 @@ (first features) (cons (quote do) features)))))) +(define hs-span-mode false) + (define hs-compile (fn (src) (hs-parse (hs-tokenize src) src))) + +(define + hs-parse-ast + (fn + (src) + (do + (set! hs-span-mode true) + (let + ((result (hs-parse (hs-tokenize src) src))) + (do (set! hs-span-mode false) result))))) + +;; ── Built-in feature registrations ──────────────────────────────── +;; These mirror the original parse-feat cond branches. Registering at +;; load time means plugins can override or extend; ctx exposes the +;; parser internals each fn needs. +(begin + (hs-register-feature! + "on" + (fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-on-feat))))) + (hs-register-feature! + "init" + (fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-init-feat))))) + (hs-register-feature! + "def" + (fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-def-feat))))) + (hs-register-feature! + "behavior" + (fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-behavior-feat))))) + (hs-register-feature! + "live" + (fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-live-feat))))) + (hs-register-feature! + "when" + (fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-when-feat))))) + (hs-register-feature! + "bind" + (fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-bind-feat))))) + (hs-register-feature! + "socket" + (fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-socket-feat)))))) diff --git a/lib/hyperscript/plugins/prolog.sx b/lib/hyperscript/plugins/prolog.sx new file mode 100644 index 00000000..24f66195 --- /dev/null +++ b/lib/hyperscript/plugins/prolog.sx @@ -0,0 +1,24 @@ +;; lib/hyperscript/plugins/prolog.sx — Prolog plugin +;; +;; Provides the `prolog` HS-level function. Replaces the ad-hoc +;; hs-prolog-hook / hs-set-prolog-hook! slots that previously lived in +;; lib/hyperscript/runtime.sx (nodes 140–142 of the plugin design doc). +;; +;; Two-step wiring preserves the original API: +;; 1. lib/prolog/runtime.sx loaded → defines pl-query-one +;; 2. lib/prolog/hs-bridge.sx (or this file's auto-wire) calls +;; (hs-set-prolog-hook! (fn (db goal) (not (= nil (pl-query-one db goal))))) +;; If neither is loaded, calling (prolog db goal) raises a clear error. + +(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)))) diff --git a/lib/hyperscript/plugins/worker.sx b/lib/hyperscript/plugins/worker.sx new file mode 100644 index 00000000..14718ce6 --- /dev/null +++ b/lib/hyperscript/plugins/worker.sx @@ -0,0 +1,19 @@ +;; lib/hyperscript/plugins/worker.sx — Worker plugin (stub) +;; +;; Phase 1 of the worker plugin: the registration formerly inlined in +;; lib/hyperscript/parser.sx (E39 stub) moves here. Behaviour is +;; identical — `worker MyWorker ...` raises a helpful error directing +;; users to the full plugin (not yet implemented). +;; +;; Phase 2 (future) replaces this stub with parse-worker-feat, a +;; compiler entry, hs-worker-define!, and the postMessage-based +;; method dispatch documented in plans/designs/hs-plugin-system.md §4a. + +(define hs-worker-loaded? true) + +(hs-register-feature! + "worker" + (fn + (ctx) + (error + "worker plugin is not installed — see https://hyperscript.org/features/worker"))) diff --git a/lib/hyperscript/runtime.sx b/lib/hyperscript/runtime.sx index bcfce8cb..a0cfe523 100644 --- a/lib/hyperscript/runtime.sx +++ b/lib/hyperscript/runtime.sx @@ -12,48 +12,21 @@ ;; 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 +(define meta (host-new "Object")) + ;; Run an initializer function immediately. ;; (hs-init thunk) — called at element boot time (define - hs-on - (fn - (target event-name handler) - (let - ((wrapped (fn (event) (guard (e ((and (not (= event-name "exception")) (not (= event-name "error"))) (dom-dispatch target "exception" {:error e})) (true (raise e))) (handler event))))) - (let - ((unlisten (dom-listen target event-name wrapped)) - (prev (or (dom-get-data target "hs-unlisteners") (list)))) - (dom-set-data target "hs-unlisteners" (append prev (list unlisten))) - unlisten)))) + hs-on-every + (fn (target event-name handler) (dom-listen target event-name handler))) ;; ── Async / timing ────────────────────────────────────────────── @@ -61,11 +34,46 @@ ;; 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))) + _hs-on-caller + (let + ((_ctx (host-new "Object")) + (_m (host-new "Object")) + (_f (host-new "Object"))) + (do + (host-set! _f "type" "onFeature") + (host-set! _m "feature" _f) + (host-set! _ctx "meta" _m) + _ctx))) ;; Wait for a DOM event on a target. ;; (hs-wait-for target event-name) — suspends until event fires +(define + hs-on + (fn + (target event-name handler) + (when + (not (nil? target)) + (let + ((me-el (host-get (host-global "window") "__hs_current_me"))) + (let + ((wrapped (fn (event) (when (not (and me-el (not (hs-ref-eq me-el target)) (nil? (host-get me-el "parentElement")))) (do (host-set! meta "caller" _hs-on-caller) (host-set! meta "owner" target) (let ((__hs-no-stop false)) (guard (e ((and (not (= event-name "exception")) (not (= event-name "error"))) (do (when (and (list? e) (= (first e) "hs-halt-default")) (set! __hs-no-stop true)) (when (not __hs-no-stop) (dom-dispatch target "exception" {:error e})))) (true (raise e))) (handler event)) (when (not __hs-no-stop) (host-call event "stopPropagation")))))))) + (let + ((unlisten (dom-listen target event-name wrapped)) + (prev (or (dom-get-data target "hs-unlisteners") (list)))) + (dom-set-data + target + "hs-unlisteners" + (append prev (list unlisten))) + unlisten)))))) + +;; Wait for CSS transitions/animations to settle on an element. +(define + hs-on-every + (fn (target event-name handler) (dom-listen target event-name handler))) + +;; ── Class manipulation ────────────────────────────────────────── + +;; Toggle a single class on an element. (define hs-on-intersection-attach! (fn @@ -81,15 +89,40 @@ (host-call observer "observe" target) observer))))) -;; Wait for CSS transitions/animations to settle on an element. +;; Toggle between two classes — exactly one is active at a time. +(define + hs-on-mutation-attach! + (fn + (target mode attr-list) + (let + ((cfg-attributes (or (= mode "any") (= mode "attributes") (= mode "attrs"))) + (cfg-childList (or (= mode "any") (= mode "childList"))) + (cfg-characterData (or (= mode "any") (= mode "characterData")))) + (let + ((opts (dict "attributes" cfg-attributes "childList" cfg-childList "characterData" cfg-characterData "subtree" true))) + (when + (and (= mode "attrs") attr-list) + (dict-set! opts "attributeFilter" attr-list)) + (let + ((cb (fn (records observer) (dom-dispatch target "mutation" (dict "records" records))))) + (let + ((observer (host-new "MutationObserver" cb))) + (host-call observer "observe" target opts) + observer)))))) + +;; Take a class from siblings — add to target, remove from others. +;; (hs-take! target cls) — like radio button class behavior (define hs-init (fn (thunk) (thunk))) -;; ── Class manipulation ────────────────────────────────────────── +;; ── DOM insertion ─────────────────────────────────────────────── -;; Toggle a single class on an element. +;; Put content at a position relative to a target. +;; pos: "into" | "before" | "after" (define hs-wait (fn (ms) (perform (list (quote io-sleep) ms)))) -;; Toggle between two classes — exactly one is active at a time. +;; ── Navigation / traversal ────────────────────────────────────── + +;; Navigate to a URL. (begin (define hs-wait-for @@ -102,31 +135,60 @@ (target event-name timeout-ms) (perform (list (quote io-wait-event) target event-name timeout-ms))))) -;; 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)))) +;; Find next sibling matching a selector (or any sibling). +(define + hs-settle + (fn + (target) + (hs-null-raise! target) + (when (not (nil? target)) (perform (list (quote io-settle) target))))) -;; ── DOM insertion ─────────────────────────────────────────────── - -;; Put content at a position relative to a target. -;; pos: "into" | "before" | "after" +;; Find previous sibling matching a selector. (define hs-toggle-class! - (fn (target cls) (host-call (host-get target "classList") "toggle" cls))) + (fn + (target cls) + (hs-null-raise! target) + (when + (not (nil? target)) + (host-call (host-get target "classList") "toggle" cls)))) -;; ── Navigation / traversal ────────────────────────────────────── +;; First element matching selector within a scope. +(define + hs-toggle-var-cycle! + (fn + (win var-name values) + (let + ((current (host-get win var-name)) (n (len values))) + (define + find-idx + (fn + (i) + (if + (>= i n) + -1 + (if (= (nth values i) current) i (find-idx (+ i 1)))))) + (let + ((idx (find-idx 0))) + (host-set! + win + var-name + (if (= idx -1) (first values) (nth values (mod (+ idx 1) n)))))))) -;; Navigate to a URL. +;; Last element matching selector. (define hs-toggle-between! (fn (target cls1 cls2) - (if - (dom-has-class? target cls1) - (do (dom-remove-class target cls1) (dom-add-class target cls2)) - (do (dom-remove-class target cls2) (dom-add-class target cls1))))) + (hs-null-raise! target) + (when + (not (nil? target)) + (if + (dom-has-class? target cls1) + (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). +;; First/last within a specific scope. (define hs-toggle-style! (fn @@ -150,7 +212,6 @@ (dom-set-style target prop "hidden") (dom-set-style target prop ""))))))) -;; Find previous sibling matching a selector. (define hs-toggle-style-between! (fn @@ -162,7 +223,9 @@ (dom-set-style target prop val2) (dom-set-style target prop val1))))) -;; First element matching selector within a scope. +;; ── Iteration ─────────────────────────────────────────────────── + +;; Repeat a thunk N times. (define hs-toggle-style-cycle! (fn @@ -183,7 +246,7 @@ (true (find-next (rest remaining)))))) (dom-set-style target prop (find-next vals))))) -;; Last element matching selector. +;; Repeat forever (until break — relies on exception/continuation). (define hs-take! (fn @@ -206,7 +269,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 +287,10 @@ (dom-set-attr target name attr-val) (dom-set-attr target name "")))))))) -;; First/last within a specific scope. +;; ── Fetch ─────────────────────────────────────────────────────── + +;; Fetch a URL, parse response according to format. +;; (hs-fetch url format) — format is "json" | "text" | "html" (begin (define hs-element? @@ -234,15 +301,21 @@ hs-set-attr! (fn (el name val) - (if (nil? val) (dom-remove-attr el name) (dom-set-attr el name val)))) + (hs-null-raise! el) + (when + (not (nil? el)) + (if (nil? val) (dom-remove-attr el name) (dom-set-attr el name val))))) (define hs-toggle-attr! (fn (el name) - (if - (dom-has-attr? el name) - (dom-remove-attr el name) - (dom-set-attr el name "")))) + (hs-null-raise! el) + (when + (not (nil? el)) + (if + (dom-has-attr? el name) + (dom-remove-attr el name) + (dom-set-attr el name ""))))) (define hs-toggle-attr-val! (fn @@ -273,68 +346,111 @@ hs-set-inner-html! (fn (target value) - (do (dom-set-inner-html target value) (hs-boot-subtree! target)))) + (do + (hs-null-raise! target) + (when + (not (nil? target)) + (let + ((str-val (if (list? value) (join "" (map (fn (x) (str x)) value)) (if (= value nil) "null" (str value))))) + (do + (dom-set-inner-html target str-val) + (hs-boot-subtree! target))))))) + (define + hs-set-element! + (fn + (target value) + (let + ((parent (dom-parent target))) + (when + parent + (let + ((tmp (dom-create-element "div")) + (str-val + (if + (list? value) + (join "" (map (fn (x) (str x)) value)) + value))) + (do + (dom-set-inner-html tmp str-val) + (let + ((children (host-get tmp "children"))) + (if + (> (len children) 0) + (let + ((new-el (first children))) + (do + (host-call parent "replaceChild" new-el target) + (hs-boot-subtree! new-el))) + (hs-set-inner-html! target str-val))))))))) (define hs-put! (fn (value pos target) - (cond - ((= pos "into") + (do + (hs-null-raise! target) + (when + (not (nil? target)) (cond - ((list? target) target) - ((hs-element? value) - (do - (dom-set-inner-html target "") - (host-call target "appendChild" value))) - (true - (do - (dom-set-inner-html target value) - (hs-boot-subtree! target))))) - ((= pos "before") - (if - (hs-element? value) - (let - ((parent (dom-parent target))) - (when parent (host-call parent "insertBefore" value target))) - (let - ((parent (dom-parent target))) - (do - (dom-insert-adjacent-html target "beforebegin" value) - (when parent (hs-boot-subtree! parent)))))) - ((= pos "after") - (if - (hs-element? value) - (let - ((parent (dom-parent target)) - (next (host-get target "nextSibling"))) - (when - parent - (if - next - (host-call parent "insertBefore" value next) - (host-call parent "appendChild" value)))) - (let - ((parent (dom-parent target))) - (do - (dom-insert-adjacent-html target "afterend" value) - (when parent (hs-boot-subtree! parent)))))) - ((= pos "start") - (cond - ((list? target) (append! target value 0)) - ((hs-element? value) (dom-prepend target value)) - (true - (do - (dom-insert-adjacent-html target "afterbegin" value) - (hs-boot-subtree! target))))) - ((= pos "end") - (cond - ((list? target) (append! target value)) - ((hs-element? value) (dom-append target value)) - (true - (do - (dom-insert-adjacent-html target "beforeend" value) - (hs-boot-subtree! target))))))))) + ((= pos "innerHTML") + (cond + ((list? value) target) + ((hs-element? value) + (do + (dom-set-inner-html target "") + (host-call target "appendChild" value))) + (true + (do + (dom-set-inner-html target value) + (hs-boot-subtree! target))))) + ((or (= pos "beforebegin") (= pos "before")) + (if + (hs-element? value) + (let + ((parent (host-get target "parentNode"))) + (when parent (host-call parent "insertBefore" value target))) + (let + ((parent (host-get target "parentNode"))) + (do + (dom-insert-adjacent-html target "beforebegin" value) + (when parent (hs-boot-subtree! parent)))))) + ((or (= pos "afterend") (= pos "after")) + (if + (hs-element? value) + (let + ((parent (host-get target "parentNode")) + (next (host-get target "nextSibling"))) + (when + parent + (if + next + (host-call parent "insertBefore" value next) + (host-call parent "appendChild" value)))) + (let + ((parent (host-get target "parentNode"))) + (do + (dom-insert-adjacent-html target "afterend" value) + (when parent (hs-boot-subtree! parent)))))) + ((or (= pos "afterbegin") (= pos "start")) + (cond + ((list? value) (append! target value 0)) + ((hs-element? value) (dom-prepend target value)) + (true + (do + (dom-insert-adjacent-html target "afterbegin" value) + (hs-boot-subtree! target))))) + ((or (= pos "beforeend") (= pos "end")) + (cond + ((list? value) (append! target value)) + ((hs-element? value) (dom-append target value)) + (true + (do + (dom-insert-adjacent-html target "beforeend" value) + (hs-boot-subtree! target))))))))))) +;; ── Type coercion ─────────────────────────────────────────────── + +;; Coerce a value to a type by name. +;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc. (define hs-add-to! (fn @@ -345,21 +461,27 @@ (some (fn (x) (= x value)) target) target (append target (list value)))) + ((hs-is-set? target) (do (host-call target "add" value) target)) (true (do (host-call target "push" value) target))))) -;; ── Iteration ─────────────────────────────────────────────────── +;; ── Object creation ───────────────────────────────────────────── -;; Repeat a thunk N times. +;; Make a new object of a given type. +;; (hs-make type-name) — creates empty object/collection (define hs-remove-from! (fn (value target) - (if - (list? target) - (filter (fn (x) (not (= x value))) target) - (host-call target "splice" (host-call target "indexOf" value) 1)))) + (cond + ((list? target) (filter (fn (x) (not (= x value))) target)) + ((hs-is-set? target) (do (host-call target "delete" value) target)) + (true (host-call target "splice" (host-call target "indexOf" value) 1))))) -;; Repeat forever (until break — relies on exception/continuation). +;; ── 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-splice-at! (fn @@ -372,7 +494,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 +508,10 @@ (host-call target "splice" i 1)))) target)))) -;; ── Fetch ─────────────────────────────────────────────────────── +;; ── Measurement ───────────────────────────────────────────────── -;; Fetch a URL, parse response according to format. -;; (hs-fetch url format) — format is "json" | "text" | "html" +;; Measure an element's bounding rect, store as local variables. +;; Returns a dict with x, y, width, height, top, left, right, bottom. (define hs-index (fn @@ -398,10 +523,10 @@ ((string? obj) (nth obj key)) (true (host-get obj key))))) -;; ── Type coercion ─────────────────────────────────────────────── - -;; Coerce a value to a type by name. -;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc. +;; 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-put-at! (fn @@ -423,10 +548,11 @@ ((= pos "start") (host-call target "unshift" value))) target))))))) -;; ── Object creation ───────────────────────────────────────────── -;; Make a new object of a given type. -;; (hs-make type-name) — creates empty object/collection +;; ── Transition ────────────────────────────────────────────────── + +;; Transition a CSS property to a value, optionally with duration. +;; (hs-transition target prop value duration) (define hs-dict-without (fn @@ -447,27 +573,14 @@ (host-call (host-global "Reflect") "deleteProperty" out key) out))))) -;; ── 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-set-on! (fn (props target) (for-each (fn (k) (host-set! target k (get props k))) (keys props)))) -;; ── 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 +589,6 @@ ((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) (define hs-answer (fn @@ -489,6 +597,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 @@ -527,7 +640,10 @@ (do (host-call ev "preventDefault") (host-call ev "stopPropagation"))))) - (when (not (= mode "the-event")) (raise (list "hs-return" nil)))))) + (when + (not (= mode "the-event")) + (raise + (list (if (= mode "default") "hs-halt-default" "hs-return") nil)))))) (define hs-select! (fn (target) (host-call target "select" (list)))) @@ -592,6 +708,10 @@ (when default-val (dom-set-prop target "value" default-val))))) (true nil))))))) + + + + (define hs-next (fn @@ -629,11 +749,60 @@ ((dom-matches? el sel) el) (true (find-prev (dom-get-prop el "previousElementSibling")))))) (find-prev sibling))))) +;; ── Sandbox/test runtime additions ────────────────────────────── +;; Property access — dot notation and .length +(define _hs-last-query-sel nil) +;; DOM query stub — sandbox returns empty list +(define + hs-null-raise! + (fn + (v) + (when + (nil? v) + (let + ((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null"))) + (host-set! (host-global "window") "_hs_null_error" msg) + (guard (_null-e (true nil)) (raise msg)))))) +;; Method dispatch — obj.method(args) +(define + hs-empty-raise! + (fn + (v) + (when + (or + (nil? v) + (and (list? v) (= (len v) 0)) + (= (host-get v "length") 0)) + (let + ((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null"))) + (host-set! (host-global "window") "_hs_null_error" msg) + (guard (_null-e (true nil)) (raise msg)))))) +;; ── 0.9.90 features ───────────────────────────────────────────── +;; beep! — debug logging, returns value unchanged +(define + hs-query-all-checked + (fn + (sel) + (let + ((result (hs-query-all sel))) + (do (hs-empty-raise! result) result)))) +;; Property-based is — check obj.key truthiness +(define + hs-dispatch! + (fn + (target event detail) + (hs-null-raise! target) + (when (not (nil? target)) (dom-dispatch target event detail)))) +;; Array slicing (inclusive both ends) (define hs-query-all - (fn (sel) (host-call (dom-body) "querySelectorAll" sel))) - + (fn + (sel) + (do + (host-set! (host-global "window") "_hs_last_query_sel" sel) + (dom-query-all (dom-document) sel)))) +;; Collection: sorted by (define hs-query-all-in (fn @@ -642,26 +811,25 @@ (nil? target) (hs-query-all sel) (host-call target "querySelectorAll" sel)))) - - - - - +;; Collection: sorted by descending (define hs-list-set (fn (lst idx val) (append (take lst idx) (cons val (drop lst (+ idx 1)))))) - +;; Collection: split by (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 +;; Collection: joined by (define hs-query-first - (fn (sel) (host-call (host-global "document") "querySelector" sel))) -;; DOM query stub — sandbox returns empty list + (fn + (sel) + (do + (host-set! (host-global "window") "_hs_last_query_sel" sel) + (host-call (host-global "document") "querySelector" sel)))) + (define hs-query-last (fn @@ -669,11 +837,9 @@ (let ((all (dom-query-all (dom-body) sel))) (if (> (len all) 0) (nth all (- (len all) 1)) nil)))) -;; Method dispatch — obj.method(args) + (define hs-first (fn (scope sel) (dom-query-all scope sel))) -;; ── 0.9.90 features ───────────────────────────────────────────── -;; beep! — debug logging, returns value unchanged (define hs-last (fn @@ -681,7 +847,7 @@ (let ((all (dom-query-all scope sel))) (if (> (len all) 0) (nth all (- (len all) 1)) nil)))) -;; Property-based is — check obj.key truthiness + (define hs-repeat-times (fn @@ -693,13 +859,18 @@ (when (< i n) (let - ((signal (guard (e ((or (= (str e) "hs-break") (= (str e) "hs-continue")) (str e)) (true (raise e))) (do (thunk) nil)))) - (cond - ((= signal "hs-break") nil) - ((= signal "hs-continue") (do-repeat (+ i 1))) - (true (do-repeat (+ i 1)))))))) + ((ex nil) (raised false)) + (do + (guard + (e (true (do (set! ex e) (set! raised true) nil))) + (do (thunk) nil)) + (cond + ((not raised) (do-repeat (+ i 1))) + ((= (str ex) "hs-break") nil) + ((= (str ex) "hs-continue") (do-repeat (+ i 1))) + (true (raise ex)))))))) (do-repeat 0))) -;; Array slicing (inclusive both ends) + (define hs-repeat-forever (fn @@ -709,13 +880,18 @@ (fn () (let - ((signal (guard (e ((or (= (str e) "hs-break") (= (str e) "hs-continue")) (str e)) (true (raise e))) (do (thunk) nil)))) - (cond - ((= signal "hs-break") nil) - ((= signal "hs-continue") (do-forever)) - (true (do-forever)))))) + ((ex nil) (raised false)) + (do + (guard + (e (true (do (set! ex e) (set! raised true) nil))) + (do (thunk) nil)) + (cond + ((not raised) (do-forever)) + ((= (str ex) "hs-break") nil) + ((= (str ex) "hs-continue") (do-forever)) + (true (raise ex))))))) (do-forever))) -;; Collection: sorted by + (define hs-repeat-while (fn @@ -723,30 +899,40 @@ (when (cond-fn) (let - ((signal (guard (e ((or (= (str e) "hs-break") (= (str e) "hs-continue")) (str e)) (true (raise e))) (do (thunk) nil)))) - (cond - ((= signal "hs-break") nil) - ((= signal "hs-continue") (hs-repeat-while cond-fn thunk)) - (true (hs-repeat-while cond-fn thunk))))))) -;; Collection: sorted by descending + ((ex nil) (raised false)) + (do + (guard + (e (true (do (set! ex e) (set! raised true) nil))) + (do (thunk) nil)) + (cond + ((not raised) (hs-repeat-while cond-fn thunk)) + ((= (str ex) "hs-break") nil) + ((= (str ex) "hs-continue") (hs-repeat-while cond-fn thunk)) + (true (raise ex)))))))) + (define hs-repeat-until (fn (cond-fn thunk) (let - ((signal (guard (e ((or (= (str e) "hs-break") (= (str e) "hs-continue")) (str e)) (true (raise e))) (do (thunk) nil)))) - (cond - ((= signal "hs-break") nil) - ((= 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 + ((ex nil) (raised false)) + (do + (guard + (e (true (do (set! ex e) (set! raised true) nil))) + (do (thunk) nil)) + (cond + ((not raised) (if (cond-fn) nil (hs-repeat-until cond-fn thunk))) + ((= (str ex) "hs-break") nil) + ((= (str ex) "hs-continue") + (if (cond-fn) nil (hs-repeat-until cond-fn thunk))) + (true (raise ex))))))) + (define hs-for-each (fn (fn-body collection) (let - ((items (cond ((list? collection) collection) ((dict? collection) (if (dict-has? collection "_order") (get collection "_order") (filter (fn (k) (not (= k "_order"))) (keys collection)))) ((nil? collection) (list)) (true (list))))) + ((items (cond ((list? collection) collection) ((nil? collection) (list)) ((host-iter? collection) (host-to-list collection)) ((dict? collection) (if (dict-has? collection "_order") (get collection "_order") (filter (fn (k) (not (= k "_order"))) (keys collection)))) (true (list))))) (define do-loop (fn @@ -754,13 +940,18 @@ (when (not (empty? remaining)) (let - ((signal (guard (e ((or (= (str e) "hs-break") (= (str e) "hs-continue")) (str e)) (true (raise e))) (do (fn-body (first remaining)) nil)))) - (cond - ((= signal "hs-break") nil) - ((= signal "hs-continue") (do-loop (rest remaining))) - (true (do-loop (rest remaining)))))))) + ((ex nil) (raised false)) + (do + (guard + (e (true (do (set! ex e) (set! raised true) nil))) + (do (fn-body (first remaining)) nil)) + (cond + ((not raised) (do-loop (rest remaining))) + ((= (str ex) "hs-break") nil) + ((= (str ex) "hs-continue") (do-loop (rest remaining))) + (true (raise ex)))))))) (do-loop items)))) -;; Collection: joined by + (begin (define hs-append @@ -774,9 +965,16 @@ (some (fn (x) (= x value)) target) target (append target (list value)))) + ((hs-is-set? target) (do (host-call target "add" value) target)) ((hs-element? target) (do - (dom-insert-adjacent-html target "beforeend" (str value)) + (dom-insert-adjacent-html + target + "beforeend" + (if + (hs-element? value) + (host-get value "outerHTML") + (str value))) target)) (true (str target value))))) (define @@ -786,16 +984,22 @@ (cond ((nil? target) nil) ((hs-element? target) - (dom-insert-adjacent-html target "beforeend" (str value))) + (dom-insert-adjacent-html + target + "beforeend" + (if + (hs-element? value) + (host-get value "outerHTML") + (str value)))) (true nil))))) - +;; Collection: joined by (define hs-sender (fn (event) (let ((detail (host-get event "detail"))) - (if detail (host-get detail "sender") nil)))) + (if detail (get detail "sender") nil)))) (define hs-host-to-sx @@ -852,14 +1056,39 @@ out))))))))))) (define - hs-fetch + hs-fetch-impl (fn - (url format) + (url format no-throw) (let - ((fmt (cond ((nil? format) "text") ((or (= format "json") (= format "JSON") (= format "Object")) "json") ((or (= format "html") (= format "HTML")) "html") ((or (= format "response") (= format "Response")) "response") ((or (= format "text") (= format "Text")) "text") (true format)))) + ((fmt (cond ((nil? format) "text") ((or (= format "json") (= format "JSON") (= format "Object")) "json") ((or (= format "html") (= format "HTML")) "html") ((or (= format "response") (= format "Response")) "response") ((or (= format "text") (= format "Text")) "text") ((or (= format "number") (= format "Number")) "number") (true "text")))) + (let + ((_hs-before-caller (host-get meta "owner"))) + (when + _hs-before-caller + (dom-dispatch _hs-before-caller "hyperscript:beforeFetch" {:url url}))) (let ((raw (perform (list "io-fetch" url fmt)))) - (cond ((= fmt "json") (hs-host-to-sx raw)) (true raw)))))) + (begin + (when + (= (host-get raw "_network-error") true) + (raise (or (host-get raw "message") "Network error"))) + (when + (and + (not no-throw) + (not (= fmt "response")) + (= (host-get raw "ok") false)) + (raise (str "HTTP Error: " (host-get raw "status")))) + (cond + ((= fmt "response") raw) + ((= fmt "json") + (hs-host-to-sx (perform (list "io-parse-json" raw)))) + ((= fmt "number") + (hs-to-number (perform (list "io-parse-text" raw)))) + (true (perform (list "io-parse-text" raw))))))))) + +(define hs-fetch (fn (url format) (hs-fetch-impl url format false))) + +(define hs-fetch-no-throw (fn (url format) (hs-fetch-impl url format true))) (define hs-json-escape @@ -926,6 +1155,41 @@ "}"))) (true (hs-json-escape (str v)))))) +(begin + (define _hs-custom-conversions {}) + (define _hs-dynamic-converters (list)) + (define + hs-set-conversion! + (fn (name conv-fn) (dict-set! _hs-custom-conversions name conv-fn))) + (define + hs-clear-conversion! + (fn (name) (dict-set! _hs-custom-conversions name nil))) + (define + hs-add-dynamic-converter! + (fn + (conv-fn) + (set! + _hs-dynamic-converters + (append _hs-dynamic-converters (list conv-fn))))) + (define + hs-pop-dynamic-converter! + (fn + () + (let + ((n (len _hs-dynamic-converters))) + (when + (> n 0) + (set! + _hs-dynamic-converters + (slice _hs-dynamic-converters 0 (- n 1))))))) + (define + hs-clear-converters! + (fn + () + (do + (set! _hs-custom-conversions {}) + (set! _hs-dynamic-converters (list)))))) + (define hs-coerce (fn @@ -945,14 +1209,23 @@ ((= type-name "Array") (if (list? value) value (list value))) ((= type-name "HTML") (cond - ((list? value) (join "" (map (fn (x) (str x)) value))) + ((list? value) + (join + "" + (map + (fn + (x) + (if (hs-element? x) (host-get x "outerHTML") (str x))) + value))) ((hs-element? value) (host-get value "outerHTML")) (true (str value)))) ((= type-name "JSON") (cond - ((string? value) (guard (_e (true value)) (json-parse value))) - ((dict? value) (hs-json-stringify value)) - ((list? value) (hs-json-stringify value)) + ((string? value) + (guard (_e (true value)) (hs-host-to-sx (json-parse value)))) + ((not (nil? (host-get value "_json"))) + (hs-host-to-sx (perform (list "io-parse-json" value)))) + ((dict? value) value) (true value))) ((= type-name "Object") (if @@ -994,7 +1267,25 @@ ((factor (pow 10 digits))) (str (/ (floor (+ (* num factor) 0.5)) factor)))))) ((= type-name "Selector") (str value)) - ((= type-name "Fragment") value) + ((= type-name "Fragment") + (let + ((frag (host-call (dom-document) "createDocumentFragment"))) + (do + (for-each + (fn + (item) + (if + (hs-element? item) + (dom-append frag item) + (let + ((tmp (dom-create-element "div"))) + (do + (dom-set-inner-html tmp (str item)) + (for-each + (fn (k) (dom-append frag k)) + (host-get tmp "children")))))) + (if (list? value) value (list value))) + frag))) ((= type-name "Values") (hs-as-values value)) ((= type-name "Keys") (if @@ -1030,23 +1321,33 @@ value) value)) ((= type-name "Set") - (if - (list? value) - (reduce - (fn - (acc x) - (if (some (fn (a) (= a x)) acc) acc (append acc (list x)))) - (list) - value) - value)) + (let + ((s (host-new "Set"))) + (do + (when + (list? value) + (for-each (fn (x) (host-call s "add" x)) value)) + s))) ((= type-name "Map") - (if - (dict? value) - (let - ((ks (if (dict-has? value "_order") (get value "_order") (filter (fn (k) (not (= k "_order"))) (keys value))))) - (map (fn (k) (list k (get value k))) ks)) - value)) - (true value)))) + (let + ((m (host-new "Map"))) + (do + (when + (dict? value) + (for-each + (fn (k) (host-call m "set" k (get value k))) + (filter (fn (k) (not (= k "_order"))) (keys value)))) + m))) + ((= type-name "Date") (host-new "Date" value)) + (true + (let + ((static-fn (get _hs-custom-conversions type-name))) + (if + (not (nil? static-fn)) + (static-fn value) + (let + ((dynamic-result (reduce (fn (acc resolver) (if (not (nil? acc)) acc (resolver type-name value))) nil _hs-dynamic-converters))) + (if (not (nil? dynamic-result)) dynamic-result value)))))))) (define hs-gather-form-nodes @@ -1111,7 +1412,19 @@ (if (host-get node "multiple") (hs-select-multi-values node) - (host-get node "value"))) + (let + ((idx (host-get node "selectedIndex")) + (opts (host-get node "options")) + (raw-val (host-get node "value"))) + (if + (and (not (nil? raw-val)) (not (= raw-val ""))) + raw-val + (if + (and (not (nil? opts)) (>= idx 0)) + (host-get + (if (list? opts) (nth opts idx) (host-get opts idx)) + "value") + ""))))) ((or (= typ "checkbox") (= typ "radio")) (if (host-get node "checked") (host-get node "value") nil)) (true (host-get node "value")))))) @@ -1229,8 +1542,8 @@ (cond ((= type-name "Object") (dict)) ((= type-name "Array") (list)) - ((= type-name "Set") (list)) - ((= type-name "Map") (dict)) + ((= type-name "Set") (host-new "Set")) + ((= type-name "Map") (host-new "Map")) (true (dict))) (apply host-new (cons type-name args))))))) (define @@ -1310,10 +1623,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})))) @@ -1322,20 +1639,33 @@ (define hs-measure - (fn (target) (perform (list (quote io-measure) target)))) + (fn + (target) + (hs-null-raise! target) + (when (not (nil? target)) (perform (list (quote io-measure) target))))) (define hs-transition (fn (target prop value duration) + (hs-null-raise! target) (when - duration - (dom-set-style - target - "transition" - (str prop " " (/ duration 1000) "s"))) - (dom-set-style target prop value) - (when duration (hs-settle target)))) + (not (nil? target)) + (let + ((init-attr (str "data-hs-transition-" prop))) + (when + (not (dom-get-attr target init-attr)) + (dom-set-attr target init-attr (dom-get-style target prop))) + (let + ((actual-value (if (= value "initial") (dom-get-attr target init-attr) value))) + (when + duration + (dom-set-style + target + "transition" + (str prop " " (/ duration 1000) "s"))) + (dom-set-style target prop actual-value) + (when duration (hs-settle target))))))) (define hs-transition-from @@ -1398,6 +1728,16 @@ hs-strict-eq (fn (a b) (and (= (type-of a) (type-of b)) (= a b)))) + +(define + hs-id= + (fn + (a b) + (if + (and (= (host-typeof a) "element") (= (host-typeof b) "element")) + (hs-ref-eq a b) + (= a b)))) + (define hs-eq-ignore-case (fn (a b) (= (downcase (str a)) (downcase (str b))))) @@ -1422,7 +1762,34 @@ (define hs-scoped-set! - (fn (el name val) (dom-set-data el (str "hs-local-" name) val))) + (fn + (el name val) + (let + ((changed (not (= (hs-scoped-get el name) val)))) + (do + (dom-set-data el (str "hs-local-" name) val) + (when changed (hs-scoped-fire-watchers! el name val)))))) + +(begin + (define _hs-scoped-watchers (list)) + (define + hs-scoped-watch! + (fn + (el name handler) + (set! + _hs-scoped-watchers + (cons (list el name handler) _hs-scoped-watchers)))) + (define + hs-scoped-fire-watchers! + (fn + (el name val) + (for-each + (fn + (entry) + (when + (and (= (nth entry 0) el) (= (nth entry 1) name)) + ((nth entry 2) val))) + _hs-scoped-watchers)))) (define hs-scoped-get @@ -1438,7 +1805,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 @@ -1515,6 +1885,25 @@ (hs-contains? (rest collection) item)))))) (true false)))) +(define + hs-in? + (fn + (collection item) + (cond + ((nil? collection) (list)) + ((list? collection) + (cond + ((nil? item) (list)) + ((list? item) + (filter (fn (x) (hs-contains? collection x)) item)) + ((hs-contains? collection item) (list item)) + (true (list)))) + (true (list))))) + +(define + hs-in-bool? + (fn (collection item) (not (hs-falsy? (hs-in? collection item))))) + (define hs-is (fn @@ -1540,7 +1929,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 @@ -1561,6 +1953,8 @@ (cond ((list? v) (list)) ((dict? v) (dict)) + ((hs-is-set? v) (host-new "Set")) + ((hs-is-map? v) (host-new "Map")) ((string? v) "") ((nil? v) nil) (true v)))) @@ -1591,7 +1985,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 +2015,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 +2060,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 +2072,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 +2158,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 +2261,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 @@ -1879,6 +2285,7 @@ hs-hide! (fn (target strategy) + (hs-empty-raise! target) (if (list? target) (do (for-each (fn (el) (hs-hide-one! el strategy)) target) target) @@ -1895,7 +2302,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 @@ -1920,6 +2328,7 @@ hs-show! (fn (target strategy) + (hs-empty-raise! target) (if (list? target) (do (for-each (fn (el) (hs-show-one! el strategy)) target) target) @@ -1999,10 +2408,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))) @@ -2058,22 +2471,42 @@ (fn (pairs) (let - ((d {}) (order (list))) + ((d {})) (do (for-each (fn (pair) (let - ((k (first pair))) + ((name (first pair))) (do - (when - (not (dict-has? d k)) - (set! order (append order (list k)))) - (dict-set! d k (nth pair 1))))) + (dict-set! d name (nth pair 1)) + (dict-set! + d + "_order" + (append (or (get d "_order") (list)) (list name)))))) pairs) - (when (not (empty? order)) (dict-set! d "_order" order)) d)))) +(define + hs-strip-order-deep + (fn + (val) + (cond + ((dict? val) + (let + ((d (dict))) + (do + (for-each + (fn + (k) + (when + (not (= k "_order")) + (dict-set! d k (hs-strip-order-deep (get val k))))) + (filter (fn (k) (not (= k "_order"))) (keys val))) + d))) + ((list? val) (map hs-strip-order-deep val)) + (true val)))) + (define hs-method-call (fn @@ -2093,9 +2526,18 @@ (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)))) + (true + (let + ((fn-val (host-get obj method))) + (cond + ((and fn-val (callable? fn-val)) (apply fn-val args)) + (fn-val (apply host-call (cons obj (cons method args)))) + (true nil))))))) (define hs-beep (fn (v) v)) @@ -2179,7 +2621,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)) @@ -2378,6 +2821,8 @@ ((store (host-get el "__hs_vars"))) (if (nil? store) nil (host-get store name))))) +;; ── SourceInfo API ──────────────────────────────────────────────── + (define hs-dom-set-var-raw! (fn @@ -2466,6 +2911,37 @@ ((nth entry 2) val))) _hs-dom-watchers))) +(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 @@ -2474,3 +2950,350 @@ ((nil? b) false) ((= a b) true) (true (hs-dom-is-ancestor? a (dom-parent b)))))) + +(define + hs-win-call + (fn + (fn-name args) + (let + ((fn (host-get (host-global "window") fn-name))) + (if + fn + (let + ((result (host-call-fn-raising fn args))) + (if + (= result "__hs_js_throw__") + (raise (host-take-js-throw)) + (if + (= result "__hs_async_error__") + (raise "__hs_async_error__") + (if + (= (host-typeof result) "promise") + (let + ((state (host-promise-state result))) + (if + (and state (= (host-get state "ok") false)) + (do + (host-set! + (host-global "window") + "__hs_async_error" + (host-get state "value")) + (raise "__hs_async_error__")) + (if state (host-get state "value") result))) + result)))) + (let + ((msg (str "'" fn-name "' is null"))) + (host-set! (host-global "window") "_hs_null_error" msg) + (guard (_null-e (true nil)) (raise msg))))))) + +(define + hs-source-for + (fn + (node) + (substring (get node :src) (get node :start) (get node :end)))) + +(define + hs-line-for + (fn + (node) + (let + ((lines (split (get node :src) "\n")) + (line-idx (- (get node :line) 1))) + (if (< line-idx (len lines)) (nth lines line-idx) "")))) + +(define hs-node-get (fn (node key) (get (get node :fields) key))) + +(define hs-src (fn (src-str) (hs-source-for (hs-parse-ast src-str)))) + +(define + hs-src-at + (fn + (src-str path) + (define + walk + (fn + (node keys) + (if + (or (nil? keys) (= (len keys) 0)) + node + (walk (hs-node-get node (first keys)) (rest keys))))) + (hs-source-for (walk (hs-parse-ast src-str) path)))) + +(define + hs-line-at + (fn + (src-str path) + (define + walk + (fn + (node keys) + (if + (or (nil? keys) (= (len keys) 0)) + node + (walk (hs-node-get node (first keys)) (rest keys))))) + (hs-line-for (walk (hs-parse-ast src-str) path)))) + +(define + hs-js-exec + (fn + (param-names js-src bound-args) + (let + ((js-fn (host-new-function param-names js-src))) + (let + ((result (host-call-fn js-fn bound-args))) + (if + (= (host-typeof result) "promise") + (let + ((state (host-promise-state result))) + (if + (and state (= (host-get state "ok") false)) + (raise (host-get state "value")) + (if state (host-get state "value") result))) + result))))) + +(define + hs-raw->api-token + (fn + (raw) + (let + ((type (dict-get raw :type)) (value (dict-get raw :value))) + (cond + (= type "ident") + {:value value :type "IDENTIFIER" :op false} + (= type "keyword") + {:value value :type "IDENTIFIER" :op false} + (= type "number") + {:value value :type "NUMBER" :op false} + (= type "string") + {:value value :type "STRING" :op false} + (= type "class") + {:value (str "." value) :type "CLASS_REF" :op false} + (= type "id") + {:value (str "#" value) :type "ID_REF" :op false} + (= type "attr") + {:value value :type "ATTRIBUTE_REF" :op false} + (= type "style") + {:value value :type "STYLE_REF" :op false} + (= type "selector") + {:value value :type "QUERY_REF" :op false} + (= type "eof") + {:value "<<>>" :type "EOF" :op false} + (= type "paren-open") + {:value value :type "L_PAREN" :op true} + (= type "paren-close") + {:value value :type "R_PAREN" :op true} + (= type "bracket-open") + {:value value :type "L_BRACKET" :op true} + (= type "bracket-close") + {:value value :type "R_BRACKET" :op true} + (= type "brace-open") + {:value value :type "L_BRACE" :op true} + (= type "brace-close") + {:value value :type "R_BRACE" :op true} + (= type "comma") + {:value value :type "COMMA" :op true} + (= type "dot") + {:value value :type "PERIOD" :op true} + (= type "colon") + {:value value :type "COLON" :op true} + (= type "op") + (cond + (= value "+") + {:value value :type "PLUS" :op true} + (= value "-") + {:value value :type "MINUS" :op true} + (= value "*") + {:value value :type "MULTIPLY" :op true} + (= value "/") + {:value value :type "SLASH" :op true} + (= value "!") + {:value value :type "EXCLAMATION" :op true} + (= value "?") + {:value value :type "QUESTION" :op true} + (= value "#") + {:value value :type "POUND" :op true} + (= value "&") + {:value value :type "AMPERSAND" :op true} + (= value "=") + {:value value :type "EQUALS" :op true} + (= value "<") + {:value value :type "L_ANG" :op true} + (= value ">") + {:value value :type "R_ANG" :op true} + (= value "<=") + {:value value :type "LTE_ANG" :op true} + (= value ">=") + {:value value :type "GTE_ANG" :op true} + (= value "==") + {:value value :type "EQ" :op true} + (= value "===") + {:value value :type "EQQ" :op true} + (= value "..") + {:value value :type "PERIOD_PERIOD" :op true} + :else {:value value :type value :op true}) + :else {:value (or value "") :type (str type) :op false})))) + +(define hs-eof-sentinel {:value "<<>>" :type "EOF" :op false}) + +(define + hs-tokens-of + (fn + (src &rest args) + (let + ((template (some (fn (a) (equal? a :template)) args))) + (let + ((raw (if template (hs-tokenize-template src) (hs-tokenize src)))) + {:pos 0 :list (filter (fn (t) (not (= (dict-get t :type) "EOF"))) (map hs-raw->api-token raw)) :source src})))) + +(define + hs-stream-token + (fn + (s i) + (let + ((lst (dict-get s :list)) (n (len (dict-get s :list)))) + (define + find + (fn + (pos count) + (if + (>= pos n) + hs-eof-sentinel + (let + ((tok (nth lst pos))) + (if + (= (dict-get tok :type) "whitespace") + (find (+ pos 1) count) + (if (= count 0) tok (find (+ pos 1) (- count 1)))))))) + (find (dict-get s :pos) i)))) + +(define + hs-stream-consume + (fn + (s) + (let + ((lst (dict-get s :list)) (n (len (dict-get s :list)))) + (define + find-pos + (fn + (pos) + (if + (>= pos n) + pos + (if + (= (dict-get (nth lst pos) :type) "whitespace") + (find-pos (+ pos 1)) + pos)))) + (let + ((p (find-pos (dict-get s :pos)))) + (let + ((tok (if (>= p n) hs-eof-sentinel (nth lst p)))) + (do + (when + (not (= (dict-get tok :type) "EOF")) + (dict-set! s :pos (+ p 1))) + tok)))))) + +(define + hs-stream-has-more + (fn (s) (not (= (dict-get (hs-stream-token s 0) :type) "EOF")))) + +(define hs-token-type (fn (tok) (dict-get tok :type))) + +(define hs-token-value (fn (tok) (dict-get tok :value))) + +(define hs-token-op? (fn (tok) (dict-get tok :op))) + +(define + hs-try-json-parse + (fn (data) (if (string? data) (guard (_e nil) (json-parse data)) nil))) + +(define + hs-socket-normalise-url + (fn + (url) + (if + (or (starts-with? url "ws://") (starts-with? url "wss://")) + url + (let + ((proto (host-get (host-global "location") "protocol")) + (host-str (host-get (host-global "location") "host"))) + (let + ((scheme (if (= proto "https:") "wss://" "ws://"))) + (str scheme host-str url)))))) + +(define + hs-socket-bind-name! + (fn + (name-path wrapper) + (let + ((win (host-global "window"))) + (if + (= (len name-path) 1) + (host-set! win (first name-path) wrapper) + (do + (when + (nil? (host-get win (first name-path))) + (host-set! win (first name-path) (host-new "Object"))) + (host-set! + (host-get win (first name-path)) + (nth name-path 1) + wrapper)))))) + +(define + hs-socket-resolve-rpc! + (fn + (wrapper data) + (let + ((iid (host-get data "iid"))) + (when + (not (nil? iid)) + (let + ((pending (host-get wrapper "_pending"))) + (when + (not (nil? pending)) + (let + ((entry (host-get pending iid))) + (when + (not (nil? entry)) + (host-set! pending iid nil) + (if + (not (nil? (host-get data "throw"))) + (host-call-fn + (host-get entry "reject") + (list (host-get data "throw"))) + (host-call-fn + (host-get entry "resolve") + (list (host-get data "return")))))))))))) + +(define + hs-socket-register! + (fn + (name-path url timeout on-message-handler json?) + (let + ((norm-url (hs-socket-normalise-url url))) + (let + ((wrapper (host-new "Object"))) + (do + (host-set! wrapper "_url" norm-url) + (host-set! wrapper "_timeout" (if (nil? timeout) 0 timeout)) + (host-set! wrapper "_pending" (host-new "Object")) + (host-set! wrapper "_closed" false) + (let + ((ws (host-new "WebSocket" norm-url))) + (do + (host-set! wrapper "_ws" ws) + (let + ((msg-handler (host-callback (fn (evt) (do (let ((parsed (hs-try-json-parse (host-get evt "data")))) (when (and (not (nil? parsed)) (not (nil? (host-get parsed "iid")))) (hs-socket-resolve-rpc! wrapper parsed))) (when (not (nil? on-message-handler)) (if json? (let ((data (hs-try-json-parse (host-get evt "data")))) (when (not (nil? data)) (on-message-handler data))) (on-message-handler evt)))))))) + (do + (host-set! ws "onmessage" msg-handler) + (host-set! wrapper "_onmessage_handler" msg-handler) + (host-set! + ws + "onclose" + (host-callback + (fn (e) (host-set! wrapper "_closed" true)))) + (host-call-fn + (host-global "_hsSetupSocket") + (list wrapper)) + (hs-socket-bind-name! name-path wrapper) + wrapper))))))))) diff --git a/lib/hyperscript/tokenizer.sx b/lib/hyperscript/tokenizer.sx index 2483ea8c..25992902 100644 --- a/lib/hyperscript/tokenizer.sx +++ b/lib/hyperscript/tokenizer.sx @@ -8,7 +8,17 @@ ;; ── Token constructor ───────────────────────────────────────────── -(define hs-make-token (fn (type value pos) {:pos pos :value value :type type})) +(define hs-make-token + (fn (type value pos &rest extras) + (let + ((end-arg (if (>= (len extras) 1) (nth extras 0) nil)) + (line-arg (if (>= (len extras) 2) (nth extras 1) nil))) + (let + ((end (if (nil? end-arg) + (+ pos (if (nil? value) 0 (len (str value)))) + end-arg)) + (line (if (nil? line-arg) 1 line-arg))) + {:pos pos :end end :line line :value value :type type})))) ;; ── Character predicates ────────────────────────────────────────── @@ -28,6 +38,27 @@ (define hs-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r")))) +(define + hs-hex-digit? + (fn + (c) + (or + (and (>= c "0") (<= c "9")) + (and (>= c "a") (<= c "f")) + (and (>= c "A") (<= c "F"))))) + +(define + hs-hex-val + (fn + (c) + (let + ((code (char-code c))) + (cond + ((and (>= code 48) (<= code 57)) (- code 48)) + ((and (>= code 65) (<= code 70)) (- code 55)) + ((and (>= code 97) (<= code 102)) (- code 87)) + (true 0))))) + ;; ── Keyword set ─────────────────────────────────────────────────── (define @@ -110,6 +141,7 @@ "append" "settle" "transition" + "view" "over" "closest" "next" @@ -187,7 +219,8 @@ "using" "giving" "ask" - "answer")) + "answer" + "bind")) (define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords))) @@ -198,14 +231,26 @@ (fn (src) (let - ((tokens (list)) (pos 0) (src-len (len src))) + ((tokens (list)) (pos 0) (src-len (len src)) (current-line 1)) (define hs-peek (fn (offset) (if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil))) (define hs-cur (fn () (hs-peek 0))) - (define hs-advance! (fn (n) (set! pos (+ pos n)))) + (define + hs-advance! + (fn (n) + (let ((new-pos (+ pos n))) + (define + count-nl! + (fn (i) + (when (< i new-pos) + (when (= (nth src i) "\n") + (set! current-line (+ current-line 1))) + (count-nl! (+ i 1))))) + (count-nl! pos) + (set! pos new-pos)))) (define skip-ws! (fn @@ -235,10 +280,15 @@ read-number (fn (start) - (when - (and (< pos src-len) (hs-digit? (hs-cur))) - (hs-advance! 1) - (read-number start)) + (define + read-int + (fn + () + (when + (and (< pos src-len) (hs-digit? (hs-cur))) + (hs-advance! 1) + (read-int)))) + (read-int) (when (and (< pos src-len) @@ -246,15 +296,7 @@ (< (+ pos 1) src-len) (hs-digit? (hs-peek 1))) (hs-advance! 1) - (define - read-frac - (fn - () - (when - (and (< pos src-len) (hs-digit? (hs-cur))) - (hs-advance! 1) - (read-frac)))) - (read-frac)) + (read-int)) (do (when (and @@ -272,15 +314,7 @@ (< pos src-len) (or (= (hs-cur) "+") (= (hs-cur) "-"))) (hs-advance! 1)) - (define - read-exp-digits - (fn - () - (when - (and (< pos src-len) (hs-digit? (hs-cur))) - (hs-advance! 1) - (read-exp-digits)))) - (read-exp-digits)) + (read-int)) (let ((num-end pos)) (when @@ -308,7 +342,7 @@ () (cond (>= pos src-len) - nil + (error "Unterminated string") (= (hs-cur) "\\") (do (hs-advance! 1) @@ -318,15 +352,47 @@ ((ch (hs-cur))) (cond (= ch "n") - (append! chars "\n") + (do (append! chars "\n") (hs-advance! 1)) (= ch "t") - (append! chars "\t") + (do (append! chars "\t") (hs-advance! 1)) + (= ch "r") + (do (append! chars "\r") (hs-advance! 1)) + (= ch "b") + (do + (append! chars (char-from-code 8)) + (hs-advance! 1)) + (= ch "f") + (do + (append! chars (char-from-code 12)) + (hs-advance! 1)) + (= ch "v") + (do + (append! chars (char-from-code 11)) + (hs-advance! 1)) (= ch "\\") - (append! chars "\\") + (do (append! chars "\\") (hs-advance! 1)) (= ch quote-char) - (append! chars quote-char) - :else (do (append! chars "\\") (append! chars ch))) - (hs-advance! 1))) + (do (append! chars quote-char) (hs-advance! 1)) + (= ch "x") + (do + (hs-advance! 1) + (if + (and + (< (+ pos 1) src-len) + (hs-hex-digit? (hs-cur)) + (hs-hex-digit? (hs-peek 1))) + (let + ((d1 (hs-hex-val (hs-cur))) + (d2 (hs-hex-val (hs-peek 1)))) + (append! + chars + (char-from-code (+ (* d1 16) d2))) + (hs-advance! 2)) + (error "Invalid hexadecimal escape: \\x"))) + :else (do + (append! chars "\\") + (append! chars ch) + (hs-advance! 1))))) (loop)) (= (hs-cur) quote-char) (hs-advance! 1) @@ -413,27 +479,69 @@ read-class-name (fn (start) - (when - (and - (< pos src-len) - (or - (hs-ident-char? (hs-cur)) - (= (hs-cur) ":") - (= (hs-cur) "[") - (= (hs-cur) "]"))) - (hs-advance! 1) - (read-class-name start)) - (slice src start pos))) + (define + build-name + (fn + (acc depth) + (cond + ((and (< pos src-len) (= (hs-cur) "\\") (< (+ pos 1) src-len)) + (do + (hs-advance! 1) + (let + ((c (hs-cur))) + (hs-advance! 1) + (build-name (str acc c) depth)))) + ((and (< pos src-len) (= (hs-cur) "[")) + (do + (let + ((c (hs-cur))) + (hs-advance! 1) + (build-name (str acc c) (+ depth 1))))) + ((and (< pos src-len) (= (hs-cur) "]")) + (do + (let + ((c (hs-cur))) + (hs-advance! 1) + (build-name + (str acc c) + (if (> depth 0) (- depth 1) 0))))) + ((and (< pos src-len) (> depth 0) (or (= (hs-cur) "(") (= (hs-cur) ")"))) + (do + (let + ((c (hs-cur))) + (hs-advance! 1) + (build-name (str acc c) depth)))) + ((and (< pos src-len) (or (hs-ident-char? (hs-cur)) (= (hs-cur) ":") (= (hs-cur) "&"))) + (do + (let + ((c (hs-cur))) + (hs-advance! 1) + (build-name (str acc c) depth)))) + (true acc)))) + (build-name "" 0))) (define hs-emit! (fn (type value start) - (append! tokens (hs-make-token type value start)))) + (let + ((end-pos + (max pos (+ start (if (nil? value) 0 (len (str value)))))) + (newlines-after-start + (- (len (split (slice src start (max start pos)) "\n")) 1)) + (start-line (- current-line newlines-after-start))) + (append! + tokens + (hs-make-token type value start end-pos start-line))))) (define scan! (fn () - (skip-ws!) + (let + ((ws-start pos)) + (skip-ws!) + (when + (and (> (len tokens) 0) (> pos ws-start)) + (hs-emit! "whitespace" (slice src ws-start pos) ws-start))) (when (< pos src-len) (let @@ -453,10 +561,26 @@ (= (hs-peek 1) "#") (= (hs-peek 1) "[") (= (hs-peek 1) "*") - (= (hs-peek 1) ":"))) + (= (hs-peek 1) ":") + (= (hs-peek 1) "$"))) (do (hs-emit! "selector" (read-selector) start) (scan!)) (and (= ch ".") (< (+ pos 1) src-len) (= (hs-peek 1) ".")) (do (hs-emit! "op" ".." start) (hs-advance! 2) (scan!)) + (and + (= ch ".") + (< (+ pos 1) src-len) + (or + (hs-letter? (hs-peek 1)) + (= (hs-peek 1) "-") + (= (hs-peek 1) "_")) + (> (len tokens) 0) + (let + ((lt (dict-get (nth tokens (- (len tokens) 1)) :type))) + (or + (= lt "paren-close") + (= lt "brace-close") + (= lt "bracket-close")))) + (do (hs-emit! "dot" "." start) (hs-advance! 1) (scan!)) (and (= ch ".") (< (+ pos 1) src-len) @@ -468,6 +592,18 @@ (hs-advance! 1) (hs-emit! "class" (read-class-name pos) start) (scan!)) + (and + (= ch "#") + (< (+ pos 1) src-len) + (hs-ident-start? (hs-peek 1)) + (> (len tokens) 0) + (let + ((lt (dict-get (nth tokens (- (len tokens) 1)) :type))) + (or + (= lt "paren-close") + (= lt "brace-close") + (= lt "bracket-close")))) + (do (hs-emit! "op" "#" start) (hs-advance! 1) (scan!)) (and (= ch "#") (< (+ pos 1) src-len) @@ -536,10 +672,12 @@ (do (let ((word (read-ident start))) - (hs-emit! - (if (hs-keyword? word) "keyword" "ident") - word - start)) + (let + ((full-word (if (and (< pos src-len) (= (hs-cur) "'") (< (+ pos 1) src-len) (hs-letter? (hs-peek 1)) (not (and (= (hs-peek 1) "s") (or (>= (+ pos 2) src-len) (not (hs-ident-char? (hs-peek 2))))))) (do (hs-advance! 1) (str word "'" (read-ident pos))) word))) + (hs-emit! + (if (hs-keyword? full-word) "keyword" "ident") + full-word + start))) (scan!)) (and (or (= ch "=") (= ch "!") (= ch "<") (= ch ">")) @@ -620,7 +758,101 @@ (do (hs-emit! "colon" ":" start) (hs-advance! 1) (scan!)) (= ch "|") (do (hs-emit! "op" "|" start) (hs-advance! 1) (scan!)) + (= ch "&") + (do (hs-emit! "op" "&" start) (hs-advance! 1) (scan!)) + (= ch "#") + (do (hs-emit! "op" "#" start) (hs-advance! 1) (scan!)) + (= ch "?") + (do (hs-emit! "op" "?" start) (hs-advance! 1) (scan!)) + (= ch ";") + (do (hs-emit! "op" ";" start) (hs-advance! 1) (scan!)) :else (do (hs-advance! 1) (scan!))))))) (scan!) (hs-emit! "eof" nil pos) + tokens))) + +;; ── Template-mode tokenizer (E37 API) ──────────────────────────────── +;; Used by hs-tokens-of when :template flag is set. +;; Emits outer " chars as single STRING tokens; ${ ... } as $ { }; +;; inner content is tokenized with the regular hs-tokenize. + +(define + hs-tokenize-template + (fn + (src) + (let + ((tokens (list)) (pos 0) (src-len (len src)) (current-line 1)) + (define t-cur (fn () (if (< pos src-len) (nth src pos) nil))) + (define t-peek (fn (n) (if (< (+ pos n) src-len) (nth src (+ pos n)) nil))) + (define + t-advance! + (fn (n) + (let ((new-pos (+ pos n))) + (define + t-count-nl! + (fn (i) + (when (< i new-pos) + (when (= (nth src i) "\n") + (set! current-line (+ current-line 1))) + (t-count-nl! (+ i 1))))) + (t-count-nl! pos) + (set! pos new-pos)))) + (define + t-emit! + (fn (type value) + (let + ((end-pos (+ pos (if (nil? value) 0 (len (str value)))))) + (append! + tokens + (hs-make-token type value pos end-pos current-line))))) + (define + scan-to-close! + (fn + (depth) + (when + (and (< pos src-len) (> depth 0)) + (cond + (= (t-cur) "{") + (do (t-advance! 1) (scan-to-close! (+ depth 1))) + (= (t-cur) "}") + (when (> (- depth 1) 0) (t-advance! 1) (scan-to-close! (- depth 1))) + :else (do (t-advance! 1) (scan-to-close! depth)))))) + (define + scan-template! + (fn + () + (when + (< pos src-len) + (let + ((ch (t-cur))) + (cond + (= ch "\"") + (do (t-emit! "string" "\"") (t-advance! 1) (scan-template!)) + (and (= ch "$") (= (t-peek 1) "{")) + (do + (t-emit! "op" "$") + (t-advance! 1) + (t-emit! "brace-open" "{") + (t-advance! 1) + (let + ((inner-start pos)) + (scan-to-close! 1) + (let + ((inner-src (slice src inner-start pos)) + (inner-toks (hs-tokenize inner-src))) + (for-each + (fn (tok) + (when (not (= (get tok "type") "eof")) + (append! tokens tok))) + inner-toks)) + (t-emit! "brace-close" "}") + (when (< pos src-len) (t-advance! 1))) + (scan-template!)) + (= ch "$") + (do (t-emit! "op" "$") (t-advance! 1) (scan-template!)) + (hs-ws? ch) + (do (t-advance! 1) (scan-template!)) + :else (do (t-advance! 1) (scan-template!))))))) + (scan-template!) + (t-emit! "eof" nil) tokens))) \ No newline at end of file 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/parser.sx b/lib/lua/parser.sx index d604224b..1993294a 100644 --- a/lib/lua/parser.sx +++ b/lib/lua/parser.sx @@ -3,28 +3,33 @@ (define lua-tok-value (fn (t) (if (= t nil) nil (get t :value)))) (define - lua-binop-prec - (fn - (op) - (cond - ((= op "or") 1) - ((= op "and") 2) - ((= op "<") 3) - ((= op ">") 3) - ((= op "<=") 3) - ((= op ">=") 3) - ((= op "==") 3) - ((= op "~=") 3) - ((= op "..") 5) - ((= op "+") 6) - ((= op "-") 6) - ((= op "*") 7) - ((= op "/") 7) - ((= op "%") 7) - ((= op "^") 10) - (else 0)))) + lua-op-table + (list + (list "or" 1 :left) + (list "and" 2 :left) + (list "<" 3 :left) + (list ">" 3 :left) + (list "<=" 3 :left) + (list ">=" 3 :left) + (list "==" 3 :left) + (list "~=" 3 :left) + (list ".." 5 :right) + (list "+" 6 :left) + (list "-" 6 :left) + (list "*" 7 :left) + (list "/" 7 :left) + (list "%" 7 :left) + (list "^" 10 :right))) -(define lua-binop-right? (fn (op) (or (= op "..") (= op "^")))) +(define lua-binop-prec + (fn (op) + (let ((entry (pratt-op-lookup lua-op-table op))) + (if (= entry nil) 0 (pratt-op-prec entry))))) + +(define lua-binop-right? + (fn (op) + (let ((entry (pratt-op-lookup lua-op-table op))) + (and (not (= entry nil)) (= (pratt-op-assoc entry) :right))))) (define lua-parse 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..ed7daa60 100755 --- a/lib/lua/test.sh +++ b/lib/lua/test.sh @@ -28,6 +28,9 @@ trap "rm -f $TMPFILE" EXIT cat > "$TMPFILE" << 'EPOCHS' (epoch 1) +(load "lib/guest/lex.sx") +(load "lib/guest/prefix.sx") +(load "lib/guest/pratt.sx") (load "lib/lua/tokenizer.sx") (epoch 2) (load "lib/lua/parser.sx") @@ -633,6 +636,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/lua/tokenizer.sx b/lib/lua/tokenizer.sx index 6a09788d..32512705 100644 --- a/lib/lua/tokenizer.sx +++ b/lib/lua/tokenizer.sx @@ -1,31 +1,12 @@ -(define lua-make-token (fn (type value pos) {:pos pos :value value :type type})) +(prefix-rename "lua-" + '((make-token lex-make-token) + (digit? lex-digit?) + (hex-digit? lex-hex-digit?) + (letter? lex-alpha?) + (ident-start? lex-ident-start?) + (ident-char? lex-ident-char?) + (ws? lex-whitespace?))) -(define lua-digit? (fn (c) (and (not (= c nil)) (>= c "0") (<= c "9")))) - -(define - lua-hex-digit? - (fn - (c) - (and - (not (= c nil)) - (or - (lua-digit? c) - (and (>= c "a") (<= c "f")) - (and (>= c "A") (<= c "F")))))) - -(define - lua-letter? - (fn - (c) - (and - (not (= c nil)) - (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))) - -(define lua-ident-start? (fn (c) (or (lua-letter? c) (= c "_")))) - -(define lua-ident-char? (fn (c) (or (lua-ident-start? c) (lua-digit? c)))) - -(define lua-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r")))) (define lua-keywords 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.conf b/lib/prolog/conformance.conf new file mode 100644 index 00000000..6b1a542a --- /dev/null +++ b/lib/prolog/conformance.conf @@ -0,0 +1,81 @@ +# Prolog conformance config — sourced by lib/guest/conformance.sh. + +LANG_NAME=prolog +MODE=dict + +PRELOADS=( + lib/guest/pratt.sx + lib/prolog/tokenizer.sx + lib/prolog/parser.sx + lib/prolog/runtime.sx + lib/prolog/query.sx + lib/prolog/compiler.sx + lib/prolog/hs-bridge.sx +) + +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!)" +) + +emit_scoreboard_json() { + local n=${#GC_NAMES[@]} i sep + printf '{\n' + printf ' "total_passed": %d,\n' "$GC_TOTAL_PASS" + printf ' "total_failed": %d,\n' "$GC_TOTAL_FAIL" + printf ' "total": %d,\n' "$GC_TOTAL" + printf ' "suites": {' + for ((i=0; i/dev/null || date)" + printf '}\n' +} + +emit_scoreboard_md() { + local n=${#GC_NAMES[@]} i status when + when="$(date -Iseconds 2>/dev/null || date)" + printf '# Prolog scoreboard\n\n' + printf '**%d / %d passing** (%d failure(s)).\n' \ + "$GC_TOTAL_PASS" "$GC_TOTAL" "$GC_TOTAL_FAIL" + printf 'Generated %s.\n\n' "$when" + printf '| Suite | Passed | Total | Status |\n' + printf '|-------|--------|-------|--------|\n' + for ((i=0; i" 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-lookup (fn (name) (pratt-op-lookup pl-op-table name))) + +;; Token → entry (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 ",")) (pl-op-lookup ",")) + ((or (= ty "atom") (= ty "op")) (pl-op-lookup vv)) + (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 +135,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 +163,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 +218,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 +236,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 +245,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 +263,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 +285,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..d9a27d09 --- /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-07T17:35:23+00:00" +} diff --git a/lib/prolog/scoreboard.md b/lib/prolog/scoreboard.md new file mode 100644 index 00000000..a6637c73 --- /dev/null +++ b/lib/prolog/scoreboard.md @@ -0,0 +1,39 @@ +# Prolog scoreboard + +**590 / 590 passing** (0 failure(s)). +Generated 2026-05-07T17:35:23+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..c7a95f20 --- /dev/null +++ b/lib/smalltalk/scoreboard.json @@ -0,0 +1,15 @@ +{ + "date": "2026-05-06T21:06:00Z", + "programs": [ + "eight-queens.st", + "fibonacci.st", + "life.st", + "mandelbrot.st", + "quicksort.st" + ], + "program_count": 5, + "program_tests_passed": 4, + "all_tests_passed": 625, + "all_tests_total": 629, + "exit_code": 1 +} diff --git a/lib/smalltalk/scoreboard.md b/lib/smalltalk/scoreboard.md new file mode 100644 index 00000000..ce89b7e0 --- /dev/null +++ b/lib/smalltalk/scoreboard.md @@ -0,0 +1,56 @@ +# Smalltalk-on-SX Scoreboard + +_Last run: 2026-05-06T21:06:00Z_ + +## Totals + +| Suite | Passing | +|-------|---------| +| All Smalltalk-on-SX tests | **625 / 629** | +| Classic-corpus tests (`tests/programs.sx`) | **4** | + +## 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/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/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/printing.sx 19 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 +X lib/smalltalk/tests/ansi.sx: could not extract summary +X lib/smalltalk/tests/hashed.sx: could not extract summary +X lib/smalltalk/tests/pharo.sx: could not extract summary +X lib/smalltalk/tests/programs.sx: could not extract summary +``` + +## 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..23ce41fb --- /dev/null +++ b/lib/tcl/conformance.sh @@ -0,0 +1,147 @@ +#!/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/guest/lex.sx") +(load "lib/guest/prefix.sx") +(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..e72928aa --- /dev/null +++ b/lib/tcl/runtime.sx @@ -0,0 +1,3859 @@ +; Tcl-on-SX runtime evaluator +; State: {:frame frame :commands cmd-table :result last-result :output accumulated-output} +; Requires lib/fiber.sx to be loaded first (provides make-fiber, fiber-resume, fiber-done?) + +(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 "::" :coro-yield-fn nil})) + +(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)))) + ; Forward result-interp as base so state changes inside + ; the proc (e.g. :fileevents, :timers, :procs) propagate; + ; restore caller's frame/stack/result/output/code. + (assoc result-interp + :frame updated-caller + :frame-stack updated-below + :result result-val + :output (str caller-output proc-output) + :code (if (= code 2) 0 code)))))))))))))) + +(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 + ((no-nl (and (> (len args) 1) (equal? (first args) "-nonewline")))) + (let + ((args2 (if no-nl (rest args) args))) + (let + ((maybe-chan (if (> (len args2) 1) (first args2) nil)) + (is-chan + (and + (not (nil? maybe-chan)) + (or + (and + (>= (len maybe-chan) 4) + (equal? (slice maybe-chan 0 4) "file")) + (and + (>= (len maybe-chan) 4) + (equal? (slice maybe-chan 0 4) "sock")))))) + (if + is-chan + (let + ((chan (first args2)) + (text (last args2)) + (line (if no-nl text (str text "\n")))) + (let + ((_ (channel-write chan line))) + (assoc interp :result ""))) + (let + ((text (last args2)) (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-num-float? + (fn + (s) + (let + loop + ((i 0)) + (cond + ((>= i (len s)) false) + ((or (equal? (nth s i) ".") (equal? (nth s i) "e") (equal? (nth s i) "E")) + true) + (else (loop (+ i 1))))))) + +(define + tcl-parse-num + (fn (s) (if (tcl-num-float? s) (parse-float s) (parse-int s)))) + +(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-float (first args)) 0)) + (a1 (if (> (len args) 1) (parse-float (nth args 1)) 0))) + (cond + ((equal? name "abs") (str (if (< a0 0) (- 0 a0) a0))) + ((equal? name "int") (str (truncate a0))) + ((equal? name "double") (str a0)) + ((equal? name "round") (str (round a0))) + ((equal? name "floor") (str (floor a0))) + ((equal? name "ceil") (str (ceil a0))) + ((equal? name "sqrt") (str (sqrt a0))) + ((equal? name "pow") (str (pow a0 a1))) + ((equal? name "max") (str (if (>= a0 a1) a0 a1))) + ((equal? name "min") (str (if (<= a0 a1) a0 a1))) + ((equal? name "sin") (str (sin a0))) + ((equal? name "cos") (str (cos a0))) + ((equal? name "tan") (str (tan a0))) + ((equal? name "atan") (str (atan a0))) + ((equal? name "atan2") (str (atan2 a0 a1))) + ((equal? name "exp") (str (exp a0))) + ((equal? name "log") (str (log a0))) + (else (error (str "expr: unknown function: " name))))))) + +(define + tcl-apply-binop + (fn + (op l r) + (let + ((fl (tcl-num-float? l)) + (fr (tcl-num-float? r)) + (nl (tcl-parse-num l)) + (nr (tcl-parse-num r))) + (cond + ((equal? op "+") (str (+ nl nr))) + ((equal? op "-") (str (- nl nr))) + ((equal? op "*") (str (* nl nr))) + ((equal? op "/") + (if (or fl fr) (str (/ nl nr)) (str (truncate (/ nl nr))))) + ((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 (< nl nr) "1" "0")) + ((equal? op ">") (if (> nl nr) "1" "0")) + ((equal? op "<=") (if (<= nl nr) "1" "0")) + ((equal? op ">=") (if (>= nl nr) "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 (pow nl nr))) + (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) ")")) + {:tokens (rest after) :value (get inner :value)} + (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) ")")) + {:tokens (rest after-args) :value (tcl-apply-func tok (get args-r :args))} + (error (str "expr: missing ) after function call " tok)))))) + (else {:tokens rest-toks :value tok})))))) + +(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)))) {:tokens (get r :tokens) :value (if (tcl-false? (get r :value)) "1" "0")})) + ((equal? tok "-") + (let ((r (tcl-expr-parse-unary (rest tokens)))) {:tokens (get r :tokens) :value (str (- 0 (tcl-parse-num (get r :value))))})) + ((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)))) + {:tokens (get exp-r :tokens) :value (str (pow (tcl-parse-num base-val) (tcl-parse-num (get exp-r :value))))}) + {:tokens rest-toks :value base-val}))))) + +(define + tcl-expr-parse-multiplicative-rest + (fn + (tokens left) + (if + (or + (= 0 (len tokens)) + (not (contains? (list "*" "/" "%") (first tokens)))) + {:tokens tokens :value left} + (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)))) + {:tokens tokens :value left} + (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)))) + {:tokens tokens :value left} + (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)))) + {:tokens tokens :value left} + (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) "&&"))) + {:tokens tokens :value left} + (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) "||"))) + {:tokens tokens :value left} + (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)}))))))) + +; Parse -code name/number to integer +(define tcl-cmd-break (fn (interp args) (assoc interp :code 3))) + +; Parse return options from args list +; Returns {:code N :result val :errorinfo str :errorcode str} +(define tcl-cmd-continue (fn (interp args) (assoc interp :code 4))) + +(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))))) + +(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) "-"))) {:result (if (> (len remaining) 0) (first remaining) "") :errorinfo ei :errorcode ec :code code} (let ((flag (first remaining)) (rest1 (rest remaining))) (cond ((equal? flag "-code") (if (= 0 (len rest1)) {:result "" :errorinfo ei :errorcode ec :code code} (go (rest rest1) (tcl-return-code-num (first rest1)) ei ec))) ((equal? flag "-errorinfo") (if (= 0 (len rest1)) {:result "" :errorinfo "" :errorcode ec :code code} (go (rest rest1) code (first rest1) ec))) ((equal? flag "-errorcode") (if (= 0 (len rest1)) {:result "" :errorinfo ei :errorcode "" :code code} (go (rest rest1) code ei (first rest1)))) ((equal? flag "-level") (if (= 0 (len rest1)) {:result "" :errorinfo ei :errorcode ec :code code} (go (rest rest1) code ei ec))) (else {:result flag :errorinfo ei :errorcode ec :code code}))))))) + (go args 2 "" "")))) + +; --- catch command --- +; catch script ?resultVar? ?optionsVar? +(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))))) + +; --- throw command --- +; throw type message +(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)))) + +; --- try command --- +; try script ?on code var body? ... ?finally body? +(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 + ((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 + ((merged (assoc result-interp :code 0 :result (str rc) :output (str caller-output sub-output)))) + (let + ((after-rv (if (nil? result-var) merged (tcl-var-set merged result-var rv)))) + (let + ((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)))))))))))) + +(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 "")))) + +(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))) + (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 {:body (nth remaining 3) :code (nth remaining 1) :type "on" :var (nth remaining 2)}))))) ((equal? kw "finally") (if (< (len remaining) 2) acc (parse-clauses (slice remaining 2 (len remaining)) (append acc (list {:body (nth remaining 1) :type "finally"}))))) (else acc)))))) + (clauses (parse-clauses rest-args (list)))) + (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))) + (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)) + (finally-clause + (reduce + (fn + (acc c) + (if (equal? (get c :type) "finally") c acc)) + nil + clauses))) + (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))))))) + (let + ((final-result (if (nil? finally-clause) after-handler (let ((fi (tcl-eval-string (assoc after-handler :code 0) (get finally-clause :body)))) (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)))))) + +; Format helper: repeat char ch n times, building pad string +(define tcl-cmd-gets (fn (interp args) (assoc interp :result ""))) + +; Format helper: pad string s to width w +(define + tcl-cmd-subst + (fn (interp args) (assoc interp :result (last args)))) + +; Format helper: scan flag characters +(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: scan digits for width/precision +(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)))))))) + +; Main format apply: process chars, produce output string +(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}))))) + +(define + tcl-fmt-scan-num + (fn + (chars j acc-n) + (if + (>= j (len chars)) + {:num acc-n :j j} + (let + ((ch (nth chars j))) + (if + (tcl-expr-digit? ch) + (tcl-fmt-scan-num chars (+ j 1) (str acc-n ch)) + {:num acc-n :j j}))))) + +(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)) + (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 "%")) + (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))) + (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)))))))))))))))))))) + +; --- string command helpers --- + +; glob match: pattern chars list, string chars list +(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 ""))))))) + +; toupper/tolower via char tables +(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0"))) + +(define + tcl-glob-match + (fn + (pat-chars str-chars) + (cond + ((and (= 0 (len pat-chars)) (= 0 (len str-chars))) + true) + ((= 0 (len pat-chars)) false) + ((equal? (first pat-chars) "*") + (let + ((rest-pat (rest pat-chars))) + (if + (tcl-glob-match rest-pat str-chars) + true + (if + (= 0 (len str-chars)) + false + (tcl-glob-match pat-chars (rest str-chars)))))) + ((= 0 (len str-chars)) false) + ((equal? (first pat-chars) "?") + (tcl-glob-match (rest pat-chars) (rest str-chars))) + ((equal? (first pat-chars) (first str-chars)) + (tcl-glob-match (rest pat-chars) (rest str-chars))) + (else false)))) + +; strip chars from left +(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)))) + +; strip chars from right (reverse, trim left, reverse) +(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)))) + +(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)))) + +; default whitespace set +(define + tcl-reverse-list + (fn (lst) (reduce (fn (acc x) (append (list x) acc)) (list) lst))) + +; string map: apply flat list of pairs old→new to string +(define + tcl-trim-right-chars + (fn + (chars strip-set) + (tcl-reverse-list + (tcl-trim-left-chars (tcl-reverse-list chars) strip-set)))) + +; string first: index of needle in haystack starting at start +(define tcl-ws-set (list " " "\t" "\n" "\r")) + +; string last: last index of needle in haystack up to end +(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 is: check string class +(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)))))) + +(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)))))))) + + +; --- list command helpers --- + +; Quote a single list element: add braces if it contains a space or is empty +(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"))))) + +; Build a Tcl list string from an SX list of string elements +(define + tcl-cmd-string + (fn + (interp args) + (if + (= 0 (len args)) + (error "string: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ((equal? sub "length") + (assoc interp :result (str (string-length (first rest-args))))) + ((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))))))) + ((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)))))))) + ((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"))))) + ((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")))) + ((equal? sub "toupper") + (let + ((s (first rest-args))) + (assoc + interp + :result (join "" (map tcl-upcase-char (split s "")))))) + ((equal? sub "tolower") + (let + ((s (first rest-args))) + (assoc + interp + :result (join "" (map tcl-downcase-char (split s "")))))) + ((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)))))) + ((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))))) + ((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))))) + ((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))))) + ((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 ""))))) + ((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)))) + ((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)))) + ((equal? sub "is") + (let + ((class (first rest-args)) (s (nth rest-args 1))) + (assoc interp :result (tcl-string-is class s)))) + ((equal? sub "cat") (assoc interp :result (join "" rest-args))) + (else (error (str "string: unknown subcommand: " sub)))))))) + +; Resolve "end" index to numeric value given list length +(define + tcl-list-quote-elem + (fn + (elem) + (if + (or (equal? elem "") (contains? (split elem "") " ")) + (str "{" elem "}") + elem))) + +; Insertion sort for list commands (comparator: fn(a b) -> true if a before b) +(define + tcl-list-build + (fn (elems) (join " " (map tcl-list-quote-elem elems)))) + +(define + tcl-end-index + (fn (s n) (if (equal? s "end") (- n 1) (parse-int s)))) + +; --- list commands --- + +(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))) + +(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))))) + +; --- dict command helpers --- + +; Parse flat dict string into SX list of [key val] pairs +(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)))))) + +; Build flat dict string from SX list of [key val] pairs +(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))))) + +; Get value for key from flat dict string; returns nil if missing +(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)))))) + +; Set key=val in flat dict string; returns new flat dict string +(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)))) + +; Remove key from flat dict string; returns new flat dict string +(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))))) + +; --- dict command --- + +(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))))))))) + +; --- namespace helpers --- + +; Normalize a namespace name to fully-qualified form: ::ns +; Accepts: "ns", "::ns", "ns::", "::ns::", "" → "::" +(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))))) + +; Test whether string s starts with prefix p +(define + tcl-cmd-dict + (fn + (interp args) + (if + (= 0 (len args)) + (error "dict: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ((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)))) + ((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))))) + ((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))))) + ((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))))) + ((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")))) + ((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)))))) + ((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)))))) + ((equal? sub "size") + (let + ((dict-str (first rest-args))) + (assoc + interp + :result (str (len (tcl-dict-to-pairs dict-str)))))) + ((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)))))) + ((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))))))))) + ((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))) + ((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))))))) + ((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 "\"")))))))) + +; 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-ns-normalize + (fn + (ns) + (if + (or (equal? ns "") (equal? ns "::")) + "::" + (let + ((stripped (if (equal? (substring ns (- (string-length ns) 2) (string-length ns)) "::") (substring ns 0 (- (string-length ns) 2)) ns))) + (if + (equal? (substring stripped 0 2) "::") + stripped + (str "::" stripped)))))) + +; Look up a command by name with namespace resolution. +; Try: exact name → ::current-ns::name → ::name +(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))))) + +; Get all proc names in a namespace (returns list of fully-qualified names) +(define + tcl-qualify-name + (fn + (name current-ns) + (if + (tcl-starts-with? name "::") + name + (if + (equal? current-ns "::") + (str "::" name) + (str current-ns "::" name))))) + +; Check if a namespace exists (has any procs) +(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)) + {:def exact :name name} + (let + ((qualified (tcl-qualify-name name current-ns))) + (let + ((qual-def (get procs qualified))) + (if + (not (nil? qual-def)) + {:def qual-def :name qualified} + (let + ((global-name (str "::" name))) + (let + ((global-def (get procs global-name))) + (if (not (nil? global-def)) {:def global-def :name global-name} nil))))))))))) + +; Extract last component from qualified name ::ns::foo → foo +(define + tcl-ns-procs + (fn + (procs ns) + (let + ((prefix (if (equal? ns "::") "::" (str ns "::")))) + (filter + (fn + (k) + (if + (equal? ns "::") + (and + (tcl-starts-with? k "::") + (not + (tcl-starts-with? + (substring k 2 (string-length k)) + "::"))) + (tcl-starts-with? k prefix))) + (keys procs))))) + +; --- proc command --- + +(define + tcl-ns-exists? + (fn (procs ns) (> (len (tcl-ns-procs procs ns)) 0))) + +; --- parse uplevel/upvar level argument --- +; Returns absolute level number. +; current-level = len(frame-stack) +(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)))))) + +; --- uplevel command --- + +(define + tcl-cmd-proc + (fn + (interp args) + (let + ((raw-name (first args)) + (arg-spec (nth args 1)) + (body (nth args 2))) + (let + ((name (tcl-qualify-name raw-name (get interp :current-ns)))) + (let + ((proc-ns (let ((parts (filter (fn (p) (not (equal? p ""))) (split name ":")))) (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 "")))))) + +; --- upvar command --- + +(define + tcl-parse-level + (fn + (level-str current-level) + (if + (equal? (substring level-str 0 1) "#") + (parse-int (substring level-str 1 (string-length level-str))) + (- current-level (parse-int level-str))))) + +; --- global command --- + +(define + tcl-cmd-uplevel + (fn + (interp args) + (let + ((current-level (len (get interp :frame-stack)))) + (let + ((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)))))))))))))) + +; --- variable command --- + +(define + tcl-cmd-upvar + (fn + (interp args) + (let + ((current-level (len (get interp :frame-stack)))) + (let + ((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-name remote-name :upvar-level target-level})) (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 ""))))))) + +; --- namespace command --- + +; namespace ensemble dispatch fn for a given ns and map +(define + tcl-cmd-global + (fn + (interp args) + (reduce + (fn (i name) (tcl-cmd-upvar i (list "#0" name name))) + interp + args))) + +(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)))) + +; --- info command --- + +(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)) + (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)))))))))))) + +; --- coroutine support --- + +; yield: inside a coroutine body, record a yielded value +(define + tcl-cmd-namespace + (fn + (interp args) + (if + (= 0 (len args)) + (error "namespace: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ((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 + ((ns (let ((normalized (tcl-ns-normalize ns-raw)) (current-ns (get interp :current-ns))) (if (tcl-starts-with? ns-raw "::") normalized (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))) + (assoc result-interp :current-ns saved-ns)))))) + ((equal? sub "current") + (assoc interp :result (get interp :current-ns))) + ((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)))))) + ((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")))) + ((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 ""))))) + ((equal? sub "export") (assoc interp :result "")) + ((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 "")))))) + ((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 ""))))) + ((equal? sub "path") (assoc interp :result "")) + ((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 + ((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 + ((dispatch-map (if (nil? map-str) (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))) + (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 "\"")))))))) + +; yieldto: stub — yield empty string +(define + tcl-cmd-info + (fn + (interp args) + (if + (= 0 (len args)) + (error "info: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ((equal? sub "level") + (assoc interp :result (str (len (get interp :frame-stack))))) + ((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)))))) + ((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))))))) + ((equal? sub "commands") + (assoc + interp + :result (tcl-list-build (keys (get interp :commands))))) + ((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)))))) + ((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)))))) + ((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)))))) + ((equal? sub "exists") + (let + ((varname (first rest-args))) + (let + ((val (frame-lookup (get interp :frame) varname))) + (assoc interp :result (if (nil? val) "0" "1"))))) + ((equal? sub "hostname") (assoc interp :result "localhost")) + ((equal? sub "script") (assoc interp :result "")) + ((equal? sub "tclversion") (assoc interp :result "8.6")) + (else (error (str "info: unknown subcommand \"" sub "\"")))))))) + +; tcl-cmd-yield: suspend the current coroutine fiber, returning val to the resumer +(define + tcl-cmd-yield + (fn + (interp args) + (let + ((val (if (> (len args) 0) (first args) ""))) + (let + ((yield-fn (get interp :coro-yield-fn))) + (if + (nil? yield-fn) + (error "yield called outside coroutine") + (let + ((resume-val (yield-fn val))) + (assoc interp :result (if (nil? resume-val) "" resume-val)))))))) + +; tcl-cmd-yieldto: suspend the current coroutine fiber (simplified: yields "" to resumer) +(define + tcl-cmd-yieldto + (fn + (interp args) + (let + ((yield-fn (get interp :coro-yield-fn))) + (if + (nil? yield-fn) + (error "yieldto called outside coroutine") + (let + ((resume-val (yield-fn ""))) + (assoc interp :result (if (nil? resume-val) "" resume-val))))))) + +; --- clock command (stubs) --- + +(define + make-coro-cmd + (fn + (fiber) + (fn + (interp args) + (let + ((resume-val (if (> (len args) 0) (first args) ""))) + (let + ((yielded (fiber-resume fiber resume-val))) + (assoc interp :result (if (nil? yielded) "" yielded))))))) + +; --- file I/O stubs --- + +(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)))) + (let + ((base-interp (assoc interp :result "" :code 0 :coro-yield-fn nil))) + (let + ((fiber + (make-fiber + (fn + (fiber-yield _) + (let + ((coro-interp (assoc base-interp :coro-yield-fn fiber-yield))) + (let + ((cmd-fn (get (get coro-interp :commands) cmd-name))) + (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 + ((new-commands + (assoc (get interp :commands) coro-name (make-coro-cmd fiber)))) + (assoc interp :commands new-commands :result "")))))))) + +(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 (str (clock-seconds)))) + ((equal? sub "milliseconds") (assoc interp :result (str (clock-milliseconds)))) + ((equal? sub "format") + ; clock format $secs ?-format $fmt? ?-timezone $tz? ?-gmt 0|1? + (let + ((t (floor (parse-int (first rest-args)))) + (opts (rest rest-args))) + (let + ((fmt (tcl-clock-opt opts "-format" "%a %b %e %H:%M:%S %Z %Y")) + (tz (tcl-clock-tz opts))) + (assoc interp :result (clock-format t fmt tz))))) + ((equal? sub "scan") + ; clock scan $str ?-format $fmt? ?-timezone $tz? ?-gmt 0|1? + (let + ((s (first rest-args)) (opts (rest rest-args))) + (let + ((fmt (tcl-clock-opt opts "-format" "%Y-%m-%d %H:%M:%S")) + (tz (tcl-clock-tz opts))) + (assoc interp :result (str (clock-scan s fmt tz)))))) + (else (error (str "clock: unknown subcommand \"" sub "\"")))))))) + +; Helper: extract a -flag $val pair from clock args. +(define + tcl-clock-opt + (fn + (opts flag default) + (cond + ((< (len opts) 2) default) + ((equal? (first opts) flag) (nth opts 1)) + (else (tcl-clock-opt (rest (rest opts)) flag default))))) + +; Helper: derive tz string from clock opts (-timezone or -gmt). +(define + tcl-clock-tz + (fn + (opts) + (let + ((tz-explicit (tcl-clock-opt opts "-timezone" nil)) + (gmt-flag (tcl-clock-opt opts "-gmt" nil))) + (cond + ((not (nil? tz-explicit)) + (cond + ((equal? tz-explicit ":UTC") "utc") + ((equal? tz-explicit "UTC") "utc") + ((equal? tz-explicit "GMT") "utc") + (else "local"))) + ((equal? gmt-flag "1") "utc") + ((equal? gmt-flag "true") "utc") + ((not (nil? gmt-flag)) "local") + (else "utc"))))) + +(define + tcl-cmd-open + (fn + (interp args) + (let + ((path (first args)) + (mode (if (> (len args) 1) (nth args 1) "r"))) + (assoc interp :result (channel-open path mode))))) + +; gets channel ?varname? +(define + tcl-cmd-close + (fn + (interp args) + (let ((_ (channel-close (first args)))) (assoc interp :result "")))) + +(define + tcl-cmd-read + (fn + (interp args) + (let + ((chan (first args)) + (n (if (> (len args) 1) (parse-int (nth args 1)) -1))) + (assoc + interp + :result (if (< n 0) (channel-read chan) (channel-read chan n)))))) + +(define + tcl-cmd-gets-chan + (fn + (interp args) + (let + ((chan (first args)) (line (channel-read-line chan))) + (if + (nil? line) + (if + (> (len args) 1) + (assoc (tcl-var-set interp (nth args 1) "") :result "-1") + (assoc interp :result "")) + (if + (> (len args) 1) + (assoc + (tcl-var-set interp (nth args 1) line) + :result (str (len line))) + (assoc interp :result line)))))) + +(define + tcl-cmd-eof + (fn + (interp args) + (assoc interp :result (if (channel-eof? (first args)) "1" "0")))) + +(define + tcl-cmd-seek + (fn + (interp args) + (let + ((chan (first args)) + (off (parse-int (nth args 1))) + (whence (if (> (len args) 2) (nth args 2) "start"))) + (let ((_ (channel-seek chan off whence))) (assoc interp :result ""))))) + +; file command dispatcher +(define + tcl-cmd-tell + (fn + (interp args) + (assoc interp :result (str (channel-tell (first args)))))) + +(define + tcl-cmd-flush + (fn + (interp args) + (let ((_ (channel-flush (first args)))) (assoc interp :result "")))) +(define + tcl-cmd-fconfigure + (fn + (interp args) + (let + ((chan (first args)) (rest-args (rest args))) + (cond + ((= 0 (len rest-args)) + (assoc + interp + :result (str "-blocking " (if (channel-blocking? chan) "1" "0")))) + ((and + (= 2 (len rest-args)) + (equal? (first rest-args) "-blocking")) + (let + ((b (nth rest-args 1))) + (let + ((_ + (channel-set-blocking! + chan + (not (or (equal? b "0") (equal? b "false")))))) + (assoc interp :result "")))) + ((and + (= 1 (len rest-args)) + (equal? (first rest-args) "-blocking")) + (assoc interp :result (if (channel-blocking? chan) "1" "0"))) + ((and + (= 1 (len rest-args)) + (equal? (first rest-args) "-error")) + (assoc interp :result (channel-async-error chan))) + (else (assoc interp :result "")))))) + + +; ============================================================ +; Event loop: fileevent / after / vwait / update (Phase 5b) +; ============================================================ + +; :fileevents is list of (chan event script) tuples +; :timers is list of (expiry-ms script) tuples, sorted ascending by expiry + +(define + tcl-fileevent-set + (fn + (interp chan event script) + (let + ((existing (or (get interp :fileevents) (list)))) + (let + ((filtered + (filter + (fn (e) (not (and (equal? (first e) chan) (equal? (nth e 1) event)))) + existing))) + (let + ((new-list + (if (equal? script "") + filtered + (append filtered (list (list chan event script)))))) + (assoc interp :fileevents new-list)))))) + +(define + tcl-fileevent-get + (fn + (interp chan event) + (let + ((events (or (get interp :fileevents) (list)))) + (let + ((matches + (filter + (fn (e) (and (equal? (first e) chan) (equal? (nth e 1) event))) + events))) + (if (= 0 (len matches)) "" (nth (first matches) 2)))))) + +(define + tcl-timer-insert + (fn + (timers new-timer) + (cond + ((= 0 (len timers)) (list new-timer)) + ((<= (first new-timer) (first (first timers))) (cons new-timer timers)) + (else (cons (first timers) (tcl-timer-insert (rest timers) new-timer)))))) + +(define + tcl-timer-add + (fn + (interp ms script) + (let + ((expiry (+ (clock-milliseconds) ms))) + (let + ((existing (or (get interp :timers) (list)))) + (assoc interp :timers (tcl-timer-insert existing (list expiry script))))))) + +; Run one iteration of the event loop. +; poll-timeout-ms: -1 = block indefinitely, 0 = poll, N>0 = wait up to N ms. +; Returns updated interp. +(define + tcl-event-step + (fn + (interp poll-timeout-ms) + (let + ((timers (or (get interp :timers) (list))) (now-ms (clock-milliseconds))) + (let + ((expired (filter (fn (t) (<= (first t) now-ms)) timers)) + (remaining (filter (fn (t) (> (first t) now-ms)) timers))) + (let + ((interp1 + (reduce + (fn (acc t) (tcl-eval-string acc (nth t 1))) + (assoc interp :timers remaining) + expired))) + (let + ((events (or (get interp1 :fileevents) (list)))) + (let + ((read-chans + (map + (fn (e) (first e)) + (filter (fn (e) (equal? (nth e 1) "readable")) events))) + (write-chans + (map + (fn (e) (first e)) + (filter (fn (e) (equal? (nth e 1) "writable")) events))) + (next-timer-delta + (if + (= 0 (len remaining)) + -1 + (- (first (first remaining)) (clock-milliseconds))))) + (let + ((effective-timeout + (cond + ((and (>= poll-timeout-ms 0) (>= next-timer-delta 0)) + (min poll-timeout-ms next-timer-delta)) + ((>= poll-timeout-ms 0) poll-timeout-ms) + ((>= next-timer-delta 0) next-timer-delta) + (else -1)))) + (if + (and + (= 0 (len read-chans)) + (= 0 (len write-chans))) + ; nothing to select on; if timeout > 0, do a no-op wait via select + (if + (> effective-timeout 0) + (let + ((_ (io-select-channels (list) (list) effective-timeout))) + interp1) + interp1) + (let + ((select-result + (io-select-channels read-chans write-chans effective-timeout))) + (let + ((ready-r (or (get select-result :readable) (list))) + (ready-w (or (get select-result :writable) (list)))) + (let + ((interp2 + (reduce + (fn (acc chan) + (let + ((script (tcl-fileevent-get acc chan "readable"))) + (if (equal? script "") acc (tcl-eval-string acc script)))) + interp1 + ready-r))) + (reduce + (fn (acc chan) + (let + ((script (tcl-fileevent-get acc chan "writable"))) + (if (equal? script "") acc (tcl-eval-string acc script)))) + interp2 + ready-w))))))))))))) + +(define + tcl-cmd-fileevent + (fn + (interp args) + (let + ((chan (first args)) (event (nth args 1))) + (if + (= 2 (len args)) + (assoc interp :result (tcl-fileevent-get interp chan event)) + (let + ((script (nth args 2))) + (assoc (tcl-fileevent-set interp chan event script) :result "")))))) + +(define + tcl-cmd-after + (fn + (interp args) + (if + (= 0 (len args)) + (error "after: wrong # args") + (let + ((ms (parse-int (first args)))) + (if + (= 1 (len args)) + ; pure sleep — drive event loop until ms elapsed + (let + ((target-ms (+ (clock-milliseconds) ms))) + (assoc (tcl-after-sleep-loop interp target-ms) :result "")) + ; schedule timer + (let + ((script (join " " (rest args)))) + (assoc (tcl-timer-add interp ms script) :result ""))))))) + +(define + tcl-after-sleep-loop + (fn + (interp target-ms) + (let + ((now (clock-milliseconds))) + (if + (>= now target-ms) + interp + (tcl-after-sleep-loop + (tcl-event-step interp (- target-ms now)) + target-ms))))) + +(define + tcl-cmd-vwait + (fn + (interp args) + (if + (= 0 (len args)) + (error "vwait: wrong # args") + (let + ((name (first args))) + (let + ((initial (frame-lookup (get interp :frame) name))) + (assoc (tcl-vwait-loop interp name initial) :result "")))))) + +(define + tcl-vwait-loop + (fn + (interp name initial) + (let + ((cur (frame-lookup (get interp :frame) name))) + (if + (and (not (nil? cur)) (not (equal? cur initial))) + interp + (tcl-vwait-loop (tcl-event-step interp 1000) name initial))))) + +(define + tcl-cmd-update + (fn + (interp args) + (assoc (tcl-event-step interp 0) :result ""))) + +; ============================================================ +; Socket: TCP client and server (Phase 5c) +; ============================================================ + +; Internal command invoked by the auto-registered fileevent on a server +; channel. Args: (server-chan callback-word ...). Accepts one client and +; calls the user callback with (client-chan peer-host peer-port). +(define + tcl-cmd-_sock-do-accept + (fn + (interp args) + (let + ((server-chan (first args)) (cb-parts (rest args))) + (let + ((info (socket-accept server-chan))) + (let + ((client-chan (get info :channel)) + (peer-host (get info :host)) + (peer-port (str (get info :port)))) + (let + ((cmd + (join + " " + (append + cb-parts + (list client-chan peer-host peer-port))))) + (assoc (tcl-eval-string interp cmd) :result ""))))))) + +; socket host port — TCP client; returns "sockN" +; socket -server cb port — TCP server; auto-fires cb on each accept +(define + tcl-cmd-socket + (fn + (interp args) + (cond + ((= 0 (len args)) (error "socket: wrong # args")) + ((equal? (first args) "-server") + (if + (< (len args) 3) + (error "socket: usage: socket -server cb port") + (let + ((cb (nth args 1)) (port (parse-int (nth args 2)))) + (let + ((server-chan (socket-server port))) + (let + ((handler (str "_sock-do-accept " server-chan " " cb))) + (assoc + (tcl-fileevent-set interp server-chan "readable" handler) + :result server-chan)))))) + ((equal? (first args) "-async") + (if + (< (len args) 3) + (error "socket: usage: socket -async host port") + (let + ((host (nth args 1)) (port (parse-int (nth args 2)))) + (assoc interp :result (socket-connect-async host port))))) + ((= 2 (len args)) + (let + ((host (first args)) (port (parse-int (nth args 1)))) + (assoc interp :result (socket-connect host port)))) + (else (error "socket: wrong # args"))))) + + +(define + tcl-cmd-array + (fn + (interp args) + (if + (= 0 (len args)) + (error "array: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ((equal? sub "get") + (if + (= 0 (len rest-args)) + (error "array get: wrong # args") + (let + ((arr-name (first rest-args)) + (pattern + (if + (> (len rest-args) 1) + (nth rest-args 1) + nil))) + (let + ((prefix (str arr-name "(")) + (locals (get (get interp :frame) :locals))) + (let + ((pl (string-length prefix))) + (let + ((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals)))) + (let + ((filtered (if (nil? pattern) arr-keys (filter (fn (k) (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) arr-keys)))) + (assoc + interp + :result (join + " " + (reduce + (fn + (acc k) + (let + ((kn (substring k pl (- (string-length k) 1)))) + (append + acc + (list kn) + (list (get locals k))))) + (list) + filtered)))))))))) + ((equal? sub "set") + (if + (< (len rest-args) 2) + (error "array set: wrong # args") + (let + ((arr-name (first rest-args)) + (flat (tcl-list-split (nth rest-args 1)))) + (let + loop + ((pairs flat) (acc interp)) + (if + (< (len pairs) 2) + (assoc acc :result "") + (loop + (rest (rest pairs)) + (tcl-var-set + acc + (str arr-name "(" (first pairs) ")") + (nth pairs 1)))))))) + ((equal? sub "names") + (if + (= 0 (len rest-args)) + (error "array names: wrong # args") + (let + ((arr-name (first rest-args)) + (pattern + (if + (> (len rest-args) 1) + (nth rest-args 1) + nil))) + (let + ((prefix (str arr-name "(")) + (locals (get (get interp :frame) :locals))) + (let + ((pl (string-length prefix))) + (let + ((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals)))) + (let + ((filtered (if (nil? pattern) arr-keys (filter (fn (k) (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) arr-keys)))) + (assoc + interp + :result (join + " " + (map + (fn + (k) + (substring + k + pl + (- (string-length k) 1))) + filtered)))))))))) + ((equal? sub "size") + (if + (= 0 (len rest-args)) + (error "array size: wrong # args") + (let + ((prefix (str (first rest-args) "(")) + (locals (get (get interp :frame) :locals))) + (assoc + interp + :result (str + (len + (filter + (fn (k) (tcl-starts-with? k prefix)) + (keys locals)))))))) + ((equal? sub "exists") + (if + (= 0 (len rest-args)) + (error "array exists: wrong # args") + (let + ((prefix (str (first rest-args) "(")) + (locals (get (get interp :frame) :locals))) + (assoc + interp + :result (if + (> + (len + (filter + (fn (k) (tcl-starts-with? k prefix)) + (keys locals))) + 0) + "1" + "0"))))) + ((equal? sub "unset") + (if + (= 0 (len rest-args)) + (error "array unset: wrong # args") + (let + ((arr-name (first rest-args)) + (pattern + (if + (> (len rest-args) 1) + (nth rest-args 1) + nil))) + (let + ((prefix (str arr-name "(")) + (locals (get (get interp :frame) :locals))) + (let + ((pl (string-length prefix))) + (let + ((to-delete (filter (fn (k) (if (tcl-starts-with? k prefix) (if (nil? pattern) true (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) false)) (keys locals)))) + (let + ((new-locals (reduce (fn (acc k) (if (contains? to-delete k) acc (assoc acc k (get locals k)))) {} (keys locals)))) + (assoc + interp + :frame (assoc (get interp :frame) :locals new-locals) + :result "")))))))) + (else (error (str "array: unknown subcommand \"" sub "\"")))))))) + + +(define + tcl-cmd-apply + (fn + (interp args) + (if + (< (len args) 1) + (error "apply: wrong # args: should be " apply lambdaList ?arg ...? "") + (let + ((func-list (tcl-list-split (first args))) + (call-args (rest args))) + (if + (< (len func-list) 2) + (error "apply: lambdaList must be a 2 or 3 element list") + (let + ((param-spec (first func-list)) + (body (nth func-list 1)) + (ns + (if + (> (len func-list) 2) + (nth func-list 2) + nil))) + (let + ((proc-def {:args param-spec :body body :ns ns})) + (tcl-call-proc interp "#apply" proc-def call-args)))))))) + +(define + tcl-cmd-regexp + (fn + (interp args) + (define + parse-flags + (fn + (as nocase? all? inline?) + (if + (= 0 (len as)) + {:rest as :nocase nocase? :inline inline? :all all?} + (cond + ((equal? (first as) "-nocase") + (parse-flags (rest as) true all? inline?)) + ((equal? (first as) "-all") + (parse-flags (rest as) nocase? true inline?)) + ((equal? (first as) "-inline") + (parse-flags (rest as) nocase? all? true)) + (else {:rest as :nocase nocase? :inline inline? :all all?}))))) + (let + ((pf (parse-flags args false false false))) + (let + ((nocase (get pf :nocase)) + (all-mode (get pf :all)) + (inline-mode (get pf :inline)) + (ra (get pf :rest))) + (if + (< (len ra) 2) + (error "regexp: wrong # args") + (let + ((pattern (first ra)) + (str-val (nth ra 1)) + (var-args + (if (> (len ra) 2) (rest (rest ra)) (list)))) + (let + ((re (make-regexp pattern (if nocase "i" "")))) + (if + all-mode + (assoc + interp + :result (str (len (regexp-match-all re str-val)))) + (if + inline-mode + (assoc + interp + :result (join + " " + (map + (fn (m) (get m :match)) + (regexp-match-all re str-val)))) + (let + ((m (regexp-match re str-val))) + (if + (nil? m) + (assoc interp :result "0") + (let + ((interp2 (if (> (len var-args) 0) (tcl-var-set interp (first var-args) (get m :match)) interp))) + (let + ((interp3 (let loop ((vi 1) (gs (get m :groups)) (acc interp2)) (if (or (= 0 (len gs)) (>= vi (len var-args))) acc (loop (+ vi 1) (rest gs) (tcl-var-set acc (nth var-args vi) (first gs))))))) + (assoc interp3 :result "1")))))))))))))) + + + +(define + tcl-cmd-regsub + (fn + (interp args) + (define + parse-flags + (fn + (as all? nocase?) + (if + (= 0 (len as)) + {:rest as :nocase nocase? :all all?} + (cond + ((equal? (first as) "-all") + (parse-flags (rest as) true nocase?)) + ((equal? (first as) "-nocase") + (parse-flags (rest as) all? true)) + (else {:rest as :nocase nocase? :all all?}))))) + (let + ((pf (parse-flags args false false))) + (let + ((all-mode (get pf :all)) + (nocase (get pf :nocase)) + (ra (get pf :rest))) + (if + (< (len ra) 3) + (error "regsub: wrong # args") + (let + ((pattern (first ra)) + (str-val (nth ra 1)) + (replacement (nth ra 2)) + (var-name + (if (> (len ra) 3) (nth ra 3) nil))) + (let + ((re (make-regexp pattern (if nocase "i" "")))) + (let + ((result (if all-mode (regexp-replace-all re str-val replacement) (regexp-replace re str-val replacement)))) + (if + (nil? var-name) + (assoc interp :result result) + (let + ((count (if all-mode (len (regexp-match-all re str-val)) (if (nil? (regexp-match re str-val)) 0 1)))) + (assoc + (tcl-var-set interp var-name result) + :result (str count)))))))))))) + +(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 (if (file-exists? (first rest-args)) "1" "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 (if (file-isfile? (first rest-args)) "1" "0"))) + ((equal? sub "isdir") + (assoc interp :result (if (file-isdir? (first rest-args)) "1" "0"))) + ((equal? sub "isdirectory") + (assoc interp :result (if (file-isdir? (first rest-args)) "1" "0"))) + ((equal? sub "readable") + (assoc interp :result (if (file-readable? (first rest-args)) "1" "0"))) + ((equal? sub "writable") + (assoc interp :result (if (file-writable? (first rest-args)) "1" "0"))) + ((equal? sub "size") + (assoc interp :result (str (file-size (first rest-args))))) + ((equal? sub "mtime") + (assoc interp :result (str (file-mtime (first rest-args))))) + ((equal? sub "atime") + (let ((s (file-stat (first rest-args)))) + (assoc interp :result (if (nil? s) "0" (str (get s :atime)))))) + ((equal? sub "type") + (let ((s (file-stat (first rest-args)))) + (assoc interp :result (if (nil? s) "" (get s :type))))) + ((equal? sub "mkdir") + (let ((_ (file-mkdir (first rest-args)))) + (assoc interp :result ""))) + ((equal? sub "copy") + (let + ((paths + (filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args))) + (let ((_ (file-copy (first paths) (nth paths 1)))) + (assoc interp :result "")))) + ((equal? sub "rename") + (let + ((paths + (filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args))) + (let ((_ (file-rename (first paths) (nth paths 1)))) + (assoc interp :result "")))) + ((equal? sub "delete") + (let + ((paths + (filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args))) + (let + ((_ + (reduce + (fn (acc p) (let ((_ (file-delete p))) acc)) + nil + paths))) + (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-chan))) + (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))) + (let + ((i (tcl-register i "fconfigure" tcl-cmd-fconfigure))) + (let + ((i (tcl-register i "fileevent" tcl-cmd-fileevent))) + (let + ((i (tcl-register i "after" tcl-cmd-after))) + (let + ((i (tcl-register i "vwait" tcl-cmd-vwait))) + (let + ((i (tcl-register i "update" tcl-cmd-update))) + (let + ((i (tcl-register i "socket" tcl-cmd-socket))) + (let + ((i (tcl-register i "_sock-do-accept" tcl-cmd-_sock-do-accept))) + (let + ((i (tcl-register i "file" tcl-cmd-file))) + (let + ((i (tcl-register i "regexp" tcl-cmd-regexp))) + (let + ((i (tcl-register i "regsub" tcl-cmd-regsub))) + (let + ((i (tcl-register i "apply" tcl-cmd-apply))) + (tcl-register + i + "array" + tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/scoreboard.json b/lib/tcl/scoreboard.json new file mode 100644 index 00000000..2a0c76d2 --- /dev/null +++ b/lib/tcl/scoreboard.json @@ -0,0 +1,11 @@ +{ + "total": 4, + "passed": 3, + "failed": 1, + "programs": { + "assert": {"status": "PASS", "expected": "10", "got": "10"}, + "event-loop": {"status": "FAIL", "expected": "done", "got": ""}, + "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..47eb6996 --- /dev/null +++ b/lib/tcl/scoreboard.md @@ -0,0 +1,10 @@ +# Tcl-on-SX Conformance Scoreboard + +| Program | Status | Expected | Got | +|---|---|---|---| +| assert | ✓ PASS | 10 | 10 | +| event-loop | ✗ FAIL | done | | +| for-each-line | ✓ PASS | 13 | 13 | +| with-temp-var | ✓ PASS | 100 999 | 100 999 | + +**3/4 passing** diff --git a/lib/tcl/test.sh b/lib/tcl/test.sh new file mode 100755 index 00000000..fb24a662 --- /dev/null +++ b/lib/tcl/test.sh @@ -0,0 +1,116 @@ +#!/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/guest/lex.sx") +(load "lib/guest/prefix.sx") +(load "lib/tcl/tokenizer.sx") +(epoch 2) +(load "lib/tcl/parser.sx") +(epoch 3) +(load "lib/tcl/tests/parse.sx") +(epoch 4) +(load "lib/fiber.sx") +(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 2400 "$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..b53ed31f --- /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 --- + (ok "clock-seconds" + (> (parse-int (get (run "clock seconds") :result)) 0) + true) + + ; --- clock milliseconds --- + (ok "clock-milliseconds" + (> (parse-int (get (run "clock milliseconds") :result)) 0) + true) + + ; --- 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]\nread $ch\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..da980012 --- /dev/null +++ b/lib/tcl/tests/eval.sx @@ -0,0 +1,386 @@ +; 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") + (ok + "array-set-get" + (get + (run "array set a {x 1 y 2 z 3}; array get a x") + :result) + "x 1") + (ok + "array-names" + (get + (run "array set a {p 10 q 20}; lsort [array names a]") + :result) + "p q") + (ok + "array-size" + (get + (run "array set a {x 1 y 2 z 3}; array size a") + :result) + "3") + (ok + "array-exists-true" + (get + (run "array set a {x 1}; array exists a") + :result) + "1") + (ok + "array-exists-false" + (get + (run "array exists nosucharray") + :result) + "0") + (ok + "array-unset-key" + (get + (run "array set a {x 1 y 2 z 3}; array unset a y; lsort [array names a]") + :result) + "x z") + (ok + "array-scalar-access" + (get + (run "set a(foo) hello; set a(bar) world; set a(foo)") + :result) + "hello") + (ok + "array-get-all" + (get + (run "set a(k) v; set pairs [array get a]; llength $pairs") + :result) + "2") + (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..b6df6180 --- /dev/null +++ b/lib/tcl/tests/idioms.sx @@ -0,0 +1,424 @@ +; 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))) + (ok + "idiom-lmap" + (get + (run + "set result {}\nforeach x {1 2 3} { lappend result [expr {$x * $x}] }\nset result") + :result) + "1 4 9") + (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") + (ok + "idiom-string-builder" + (get + (run + "set buf \"\"\nforeach w {Hello World Tcl} { append buf $w \" \" }\nstring trimright $buf") + :result) + "Hello World Tcl") + (ok + "idiom-default-param" + (get (run "if {![info exists x]} { set x 42 }\nset x") :result) + "42") + (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") + (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") + (ok + "idiom-dict-builder" + (get + (run + "proc build-dict {args} { dict create {*}$args }\ndict get [build-dict name Alice age 30] name") + :result) + "Alice") + (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") + (ok + "idiom-string-reverse" + (get + (run + "set s hello\nset chars [split $s \"\"]\nset rev [lreverse $chars]\njoin $rev \"\"") + :result) + "olleh") + (ok "idiom-number-format" (get (run "format \"%05d\" 42") :result) "00042") + (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") + (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") + (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") + (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") + (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") + (ok + "idiom-recursive-eval" + (get + (run + "proc calc {expr} { return [::tcl::mathop::+ 0 [expr $expr]] }\nexpr {3 + 4 * 2}") + :result) + "11") + (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") + (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") + (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") + (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") + (ok + "env-lookup-basic" + (env-lookup (let ((x 42)) (current-env)) "x") + 42) + (ok + "env-lookup-missing" + (env-lookup (let ((x 42)) (current-env)) "z") + nil) + (ok + "env-extend-lookup" + (let + ((e (let ((x 5)) (current-env)))) + (env-lookup (env-extend e "y" 10) "y")) + 10) + (ok + "eval-in-env-parent" + (let + ((x 5)) + (eval-in-env (env-extend (current-env) "y" 10) (quote (+ x y)))) + 15) + (ok + "eval-in-env-multi" + (let + ((base (current-env))) + (eval-in-env + (env-extend (env-extend base "a" 3) "b" 7) + (quote (* a b)))) + 21) + + ; 26-32. Phase 5 channels: write/read/seek/tell/eof/append/non-blocking + (ok "channel-write-read" + (get + (run + "set f /tmp/tcl-phase5-1.txt\nset c [open $f w]\nputs $c \"line one\"\nputs $c \"line two\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out") + :result) + "line one\nline two\n") + + (ok "channel-gets-loop" + (get + (run + "set f /tmp/tcl-phase5-2.txt\nset c [open $f w]\nputs $c apple\nputs $c banana\nputs $c cherry\nclose $c\nset c [open $f r]\nset out {}\nwhile {[gets $c line] >= 0} {lappend out $line}\nclose $c\nfile delete $f\nreturn $out") + :result) + "apple banana cherry") + + (ok "channel-seek-tell" + (get + (run + "set f /tmp/tcl-phase5-3.txt\nset c [open $f w]\nputs -nonewline $c \"hello world\"\nclose $c\nset c [open $f r]\nseek $c 6\nset pos [tell $c]\nset rest [read $c]\nclose $c\nfile delete $f\nreturn \"$pos:$rest\"") + :result) + "6:world") + + (ok "channel-eof-after-read" + (get + (run + "set f /tmp/tcl-phase5-4.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nread $c\nset e [eof $c]\nclose $c\nfile delete $f\nreturn $e") + :result) + "1") + + (ok "channel-append-mode" + (get + (run + "set f /tmp/tcl-phase5-5.txt\nset c [open $f w]\nputs -nonewline $c \"first\"\nclose $c\nset c [open $f a]\nputs -nonewline $c \"-second\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out") + :result) + "first-second") + + (ok "channel-seek-end" + (get + (run + "set f /tmp/tcl-phase5-6.txt\nset c [open $f w]\nputs -nonewline $c \"abcdefghij\"\nclose $c\nset c [open $f r]\nseek $c 0 end\nset pos [tell $c]\nclose $c\nfile delete $f\nreturn $pos") + :result) + "10") + + (ok "channel-fconfigure-blocking" + (get + (run + "set f /tmp/tcl-phase5-7.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfconfigure $c -blocking 0\nset b [fconfigure $c -blocking]\nclose $c\nfile delete $f\nreturn $b") + :result) + "0") + + ; 33-37. Phase 5b event loop: after / vwait / fileevent / update + (ok "after-vwait-timer" + (get + (run + "after 30 {set ::done fired}\nvwait ::done\nset ::done") + :result) + "fired") + + (ok "after-multiple-timers-update" + (get + (run + "set ::n 0\nafter 0 {incr ::n}\nafter 0 {incr ::n}\nafter 0 {incr ::n}\nupdate\nset ::n") + :result) + "3") + + (ok "fileevent-readable-fires" + (get + (run + "set f /tmp/tcl-phase5b-1.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nfileevent $c readable {set ::ready 1; fileevent $::ch readable {}}\nset ::ch $c\nvwait ::ready\nclose $c\nfile delete $f\nset ::ready") + :result) + "1") + + (ok "fileevent-query-script" + (get + (run + "set f /tmp/tcl-phase5b-2.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfileevent $c readable {puts hello}\nset s [fileevent $c readable]\nclose $c\nfile delete $f\nreturn $s") + :result) + "puts hello") + + (ok "after-cancel-via-vwait-timing" + (get + (run + "set ::counter 0\nafter 10 {incr ::counter}\nafter 50 {set ::done 1}\nvwait ::done\nset ::counter") + :result) + "1") + + ; 38-41. Phase 5c sockets: TCP client + server + (ok "socket-server-fires-callback" + (get + (run + "proc h {sock host port} { global got; set got hit; close $sock }\nset srv [socket -server h 18901]\nset cli [socket localhost 18901]\nvwait got\nclose $srv\nclose $cli\nset got") + :result) + "hit") + + (ok "socket-client-server-roundtrip" + (get + (run + "proc h {sock host port} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server h 18902]\nset cli [socket localhost 18902]\nputs $cli ping\nflush $cli\nvwait received\nclose $srv\nclose $cli\nset received") + :result) + "ping") + + (ok "socket-server-peer-host" + (get + (run + "proc h {sock host port} { global peer; set peer $host; close $sock }\nset srv [socket -server h 18903]\nset cli [socket 127.0.0.1 18903]\nvwait peer\nclose $srv\nclose $cli\nset peer") + :result) + "127.0.0.1") + + (ok "socket-multiple-connections" + (get + (run + "proc h {sock host port} { global count; incr count; close $sock }\nset count 0\nset srv [socket -server h 18904]\nset c1 [socket localhost 18904]\nset c2 [socket localhost 18904]\nset c3 [socket localhost 18904]\nwhile {$count < 3} { update; after 5 }\nclose $srv\nclose $c1\nclose $c2\nclose $c3\nset count") + :result) + "3") + + ; 42-49. Phase 5d file metadata + ops + (ok "file-isfile-true" + (get + (run + "set f /tmp/tcl-phase5d-1.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset r [file isfile $f]\nfile delete $f\nreturn $r") + :result) + "1") + + (ok "file-isfile-false-on-dir" + (get (run "file isfile /tmp") :result) + "0") + + (ok "file-isdir-true" + (get (run "file isdir /tmp") :result) + "1") + + (ok "file-size" + (get + (run + "set f /tmp/tcl-phase5d-2.txt\nset c [open $f w]\nputs -nonewline $c hello\nclose $c\nset s [file size $f]\nfile delete $f\nreturn $s") + :result) + "5") + + (ok "file-readable-true" + (get (run "file readable /tmp") :result) + "1") + + (ok "file-readable-missing" + (get (run "file readable /no/such/path/here") :result) + "0") + + (ok "file-mkdir-then-isdir" + (get + (run + "set d /tmp/tcl-phase5d-mkdir/sub\nfile mkdir $d\nset r [file isdir $d]\nfile delete $d\nfile delete /tmp/tcl-phase5d-mkdir\nreturn $r") + :result) + "1") + + (ok "file-copy-roundtrip" + (get + (run + "set s /tmp/tcl-phase5d-src.txt\nset d /tmp/tcl-phase5d-dst.txt\nset c [open $s w]\nputs -nonewline $c copydata\nclose $c\nfile copy $s $d\nset c [open $d r]\nset out [read $c]\nclose $c\nfile delete $s\nfile delete $d\nreturn $out") + :result) + "copydata") + + (ok "file-rename-then-exists" + (get + (run + "set s /tmp/tcl-phase5d-r1.txt\nset d /tmp/tcl-phase5d-r2.txt\nset c [open $s w]\nputs -nonewline $c x\nclose $c\nfile rename $s $d\nset r [list [file exists $s] [file exists $d]]\nfile delete $d\nreturn $r") + :result) + "0 1") + + (ok "file-mtime-positive" + (get + (run + "set f /tmp/tcl-phase5d-mt.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset m [file mtime $f]\nfile delete $f\nexpr {$m > 0}") + :result) + "1") + + ; 52-56. Phase 5e clock format options + clock scan + (ok "clock-format-utc" + (get + (run "clock format 0 -format {%Y-%m-%d %H:%M:%S} -gmt 1") + :result) + "1970-01-01 00:00:00") + + (ok "clock-format-fmt-default" + (get + (run "clock format 1710513000 -format {%Y-%m-%d} -gmt 1") + :result) + "2024-03-15") + + (ok "clock-scan-roundtrip" + (get + (run "set t [clock scan {2024-06-15 12:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1]\nclock format $t -format {%Y-%m-%d %H:%M:%S} -gmt 1") + :result) + "2024-06-15 12:00:00") + + (ok "clock-scan-returns-int" + (get + (run "expr {[clock scan {1970-01-01 00:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1] == 0}") + :result) + "1") + + (ok "clock-format-percent-pct" + (get + (run "clock format 0 -format {%Y%%%m} -gmt 1") + :result) + "1970%01") + + ; 57-59. Phase 5f socket -async (non-blocking connect) + (ok "socket-async-completes-writable" + (get + (run + "proc h {sock host port} { close $sock }\nset srv [socket -server h 18930]\nset c [socket -async localhost 18930]\nset ready 0\nfileevent $c writable {global ready; set ready 1}\nvwait ready\nclose $c\nclose $srv\nset ready") + :result) + "1") + + (ok "socket-async-then-write" + (get + (run + "proc accept {sock host port} { global accepted_sock; set accepted_sock $sock; fileevent $sock readable [list reader $sock] }\nproc reader {sock} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server accept 18931]\nset c [socket -async localhost 18931]\nfileevent $c writable {global wready; set wready 1; fileevent $::ch writable {}}\nset ::ch $c\nvwait wready\nputs $c async-data\nflush $c\nvwait received\nclose $c\nclose $srv\nset received") + :result) + "async-data") + + (ok "socket-async-no-error" + (get + (run + "proc h {sock host port} { close $sock }\nset srv [socket -server h 18932]\nset c [socket -async localhost 18932]\nset r 0\nfileevent $c writable {global r; set r 1}\nvwait r\nset err [fconfigure $c -error]\nclose $c\nclose $srv\nreturn $err") + :result) + "") + + (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..bc094ff3 --- /dev/null +++ b/lib/tcl/tokenizer.sx @@ -0,0 +1,299 @@ +(prefix-rename "tcl-" + '((ws? lex-space?) + (alpha? lex-alpha?) + (digit? lex-digit?) + (ident-start? lex-ident-start?) + (ident-char? lex-ident-char?))) + + +(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/apl-loop.md b/plans/agent-briefings/apl-loop.md new file mode 100644 index 00000000..7ddff8e6 --- /dev/null +++ b/plans/agent-briefings/apl-loop.md @@ -0,0 +1,81 @@ +# apl-on-sx loop agent (single agent, queue-driven) + +Role: iterates `plans/apl-on-sx.md` forever. Rank-polymorphic primitives + 6 operators on the JIT is the headline showcase — APL is the densest combinator algebra you can put on top of a primitive table. Every program is `array → array` pure pipelines, exactly what the JIT was built for. + +``` +description: apl-on-sx queue loop +subagent_type: general-purpose +run_in_background: true +isolation: worktree +``` + +## Prompt + +You are the sole background agent working `/root/rose-ash/plans/apl-on-sx.md`. Isolated worktree, forever, one commit per feature. Push to `origin/loops/apl` after every commit. + +## Restart baseline — check before iterating + +1. Read `plans/apl-on-sx.md` — roadmap + Progress log. +2. `ls lib/apl/` — pick up from the most advanced file. +3. If `lib/apl/tests/*.sx` exist, run them. Green before new work. +4. If `lib/apl/scoreboard.md` exists, that's your baseline. + +## The queue + +Phase order per `plans/apl-on-sx.md`: + +- **Phase 1** — tokenizer + parser. Unicode glyphs, `¯` for negative, strands (juxtaposition), right-to-left, valence resolution by syntactic position +- **Phase 2** — array model + scalar primitives. `make-array {shape, ravel}`, scalar promotion, broadcast for `+ - × ÷ ⌈ ⌊ * ⍟ | ! ○`, comparison, logical, `⍳`, `⎕IO` +- **Phase 3** — structural primitives + indexing. `⍴ , ⍉ ↑ ↓ ⌽ ⊖ ⌷ ⍋ ⍒ ⊂ ⊃ ∊` +- **Phase 4** — **THE SHOWCASE**: operators. `f/` (reduce), `f¨` (each), `∘.f` (outer), `f.g` (inner), `f⍨` (commute), `f∘g` (compose), `f⍣n` (power), `f⍤k` (rank), `@` (at) +- **Phase 5** — dfns + tradfns + control flow. `{⍺+⍵}`, `∇` recurse, `⍺←default`, tradfn header, `:If/:While/:For/:Select` +- **Phase 6** — classic programs (life, mandelbrot, primes, n-queens, quicksort) + idiom corpus + drive to 100+ + +Within a phase, pick the checkbox that unlocks the most tests per effort. + +Every iteration: implement → test → commit → tick `[ ]` → Progress log → next. + +## Ground rules (hard) + +- **Scope:** only `lib/apl/**` and `plans/apl-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib//` dirs, `lib/stdlib.sx`, or `lib/` root. APL primitives go in `lib/apl/runtime.sx`. +- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop. +- **Shared-file issues** → plan's Blockers with minimal repro. +- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits. +- **Unicode in `.sx`:** raw UTF-8 only, never `\uXXXX` escapes. Glyphs land directly in source. +- **Worktree:** commit, then push to `origin/loops/apl`. Never touch `main`. +- **Commit granularity:** one feature per commit. +- **Plan file:** update Progress log + tick boxes every commit. + +## APL-specific gotchas + +- **Right-to-left, no precedence among functions.** `2 × 3 + 4` is `2 × (3 + 4)` = 14, not 10. Operators bind tighter than functions: `+/ ⍳5` is `+/(⍳5)`, and `2 +.× 3 4` is `2 (+.×) 3 4`. +- **Valence by position.** `-3` is monadic negate (`-` with no left arg). `5-3` is dyadic subtract. The parser must look left to decide. Same glyph; different fn. +- **`¯` is part of a number literal**, not a prefix function. `¯3` is the literal negative three; `-3` is the function call. Tokenizer eats `¯` into the numeric token. +- **Strands.** `1 2 3` is a 3-element vector, not three separate calls. Adjacent literals fuse into a strand at parse time. Adjacent names do *not* fuse — `a b c` is three separate references. +- **Scalar promotion.** `1 + 2 3 4` ↦ `3 4 5`. Any scalar broadcasts against any-rank conformable shape. +- **Conformability** = exactly matching shapes, OR one side scalar, OR (in some dialects) one side rank-1 cycling against rank-N. Keep strict in v1: matching shape or scalar only. +- **`⍳` is overloaded.** Monadic `⍳N` = vector 1..N (or 0..N-1 if `⎕IO=0`). Dyadic `V ⍳ W` = first-index lookup, returns `≢V+1` for not-found. +- **Reduce with `+/⍳0`** = `0` (identity for `+`). Each scalar primitive has a defined identity used by reduce-on-empty. Don't crash; return identity. +- **Reduce direction.** `f/` reduces the *last* axis. `f⌿` reduces the *first*. Matters for matrices. +- **Indexing is 1-based** by default (`⎕IO=1`). Do not silently translate to 0-based; respect `⎕IO`. +- **Bracket indexing** `A[I]` is sugar for `I⌷A` (squad-quad). Multi-axis: `A[I;J]` is `I J⌷A` with semicolon-separated axes; `A[;J]` selects all of axis 0. +- **Dfn `{...}`** — `⍺` = left arg (may be unbound for monadic call → check with `⍺←default`), `⍵` = right arg, `∇` = recurse. Default left arg syntax: `⍺←0`. +- **Tradfn vs dfn** — tradfns use line-numbered `→linenum` for goto; dfns use guards `cond:expr`. Pick the right one for the user's syntax. +- **Empty array** = rank-N array where some dim is 0. `0⍴⍳0` is empty rank-1. Scalar prototype matters for empty-array operations; ignore in v1, return 0/space. +- **Test corpus:** custom + idioms. Place programs in `lib/apl/tests/programs/` with `.apl` extension. + +## General gotchas (all loops) + +- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences. +- `cond`/`when`/`let` clauses evaluate only the last expr. +- `type-of` on user fn returns `"lambda"`. +- Shell heredoc `||` gets eaten — escape or use `case`. + +## Style + +- No comments in `.sx` unless non-obvious. +- No new planning docs — update `plans/apl-on-sx.md` inline. +- Short, factual commit messages (`apl: outer product ∘. (+9)`). +- One feature per iteration. Commit. Log. Next. + +Go. Read the plan; find first `[ ]`; implement. diff --git a/plans/agent-briefings/common-lisp-loop.md b/plans/agent-briefings/common-lisp-loop.md new file mode 100644 index 00000000..b82192d0 --- /dev/null +++ b/plans/agent-briefings/common-lisp-loop.md @@ -0,0 +1,80 @@ +# common-lisp-on-sx loop agent (single agent, queue-driven) + +Role: iterates `plans/common-lisp-on-sx.md` forever. Conditions + restarts on delimited continuations is the headline showcase — every other Lisp reinvents resumable exceptions on the host stack. On SX `signal`/`invoke-restart` is just a captured continuation. Plus CLOS, the LOOP macro, packages. + +``` +description: common-lisp-on-sx queue loop +subagent_type: general-purpose +run_in_background: true +isolation: worktree +``` + +## Prompt + +You are the sole background agent working `/root/rose-ash/plans/common-lisp-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push. + +## Restart baseline — check before iterating + +1. Read `plans/common-lisp-on-sx.md` — roadmap + Progress log. +2. `ls lib/common-lisp/` — pick up from the most advanced file. +3. If `lib/common-lisp/tests/*.sx` exist, run them. Green before new work. +4. If `lib/common-lisp/scoreboard.md` exists, that's your baseline. + +## The queue + +Phase order per `plans/common-lisp-on-sx.md`: + +- **Phase 1** — reader + parser (read macros `#'` `'` `` ` `` `,` `,@` `#( … )` `#:` `#\char` `#xFF` `#b1010`, ratios, dispatch chars, lambda lists with `&optional`/`&rest`/`&key`/`&aux`) +- **Phase 2** — sequential eval + special forms (`let`/`let*`/`flet`/`labels`, `block`/`return-from`, `tagbody`/`go`, `unwind-protect`, multiple values, `setf` subset, dynamic variables) +- **Phase 3** — **THE SHOWCASE**: condition system + restarts. `define-condition`, `signal`/`error`/`cerror`/`warn`, `handler-bind` (non-unwinding), `handler-case` (unwinding), `restart-case`, `restart-bind`, `find-restart`/`invoke-restart`/`compute-restarts`, `with-condition-restarts`. Classic programs (restart-demo, parse-recover, interactive-debugger) green. +- **Phase 4** — CLOS: `defclass`, `defgeneric`, `defmethod` with `:before`/`:after`/`:around`, `call-next-method`, multiple dispatch +- **Phase 5** — macros + LOOP macro + reader macros +- **Phase 6** — packages + stdlib (sequence functions, FORMAT directives, drive corpus to 200+) + +Within a phase, pick the checkbox that unlocks the most tests per effort. + +Every iteration: implement → test → commit → tick `[ ]` → Progress log → next. + +## Ground rules (hard) + +- **Scope:** only `lib/common-lisp/**` and `plans/common-lisp-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib//` dirs, `lib/stdlib.sx`, or `lib/` root. CL primitives go in `lib/common-lisp/runtime.sx`. +- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop. +- **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`. +- **Commit granularity:** one feature per commit. +- **Plan file:** update Progress log + tick boxes every commit. + +## Common-Lisp-specific gotchas + +- **`handler-bind` is non-unwinding** — handlers can decline by returning normally, in which case `signal` keeps walking the chain. **`handler-case` is unwinding** — picking a handler aborts the protected form via a captured continuation. Don't conflate them. +- **Restarts are not handlers.** `restart-case` establishes named *resumption points*; `signal` runs handler code with restarts visible; the handler chooses a restart by calling `invoke-restart`, which abandons handler stack and resumes at the restart point. Two stacks: handlers walk down, restarts wait to be invoked. +- **`block` / `return-from`** is lexical. `block name … (return-from name v) …` captures `^k` once at entry; `return-from` invokes it. `return-from` to a name not in scope is an error (don't fall back to outer block). +- **`tagbody` / `go`** — each tag in tagbody is a continuation; `go tag` invokes it. Tags are lexical, can only target tagbodies in scope. +- **`unwind-protect`** runs cleanup on *any* non-local exit (return-from, throw, condition unwind). Implement as a scope frame fired by the cleanup machinery. +- **Multiple values**: primary-value-only contexts (function args, `if` test, etc.) drop extras silently. `values` produces multiple. `multiple-value-bind` / `multiple-value-call` consume them. Don't auto-list. +- **CLOS dispatch:** sort applicable methods by argument-list specificity (`subclassp` per arg, left-to-right); standard method combination calls primary methods most-specific-first via `call-next-method` chain. `:before` runs all before primaries; `:after` runs all after, in reverse-specificity. `:around` wraps everything. +- **`call-next-method`** is a *continuation* available only inside a method body. Implement as a thunk stored in a dynamic-extent variable. +- **Generalised reference (`setf`)**: `(setf (foo x) v)` ↦ `(setf-foo v x)`. Look up the setf-expander, not just a writer fn. `define-setf-expander` is mandatory for non-trivial places. Start with the symbolic / list / aref / slot-value cases. +- **Dynamic variables (specials):** `defvar`/`defparameter` mark a symbol as special. `let` over a special name *rebinds* in dynamic extent (use parameterize-style scope), not lexical. +- **Symbols are package-qualified.** Reader resolves `cl:car`, `mypkg::internal`, bare `foo` (current package). Internal vs external matters for `:` (one colon) reads. +- **`nil` is also `()` is also the empty list.** Same object. `nil` is also false. CL has no distinct unit value. +- **LOOP macro is huge.** Build incrementally — start with `for/in`, `for/from`, `collect`, `sum`, `count`, `repeat`. Add conditional clauses (`when`, `if`, `else`) once iteration drivers stable. `named` blocks + `return-from named` last. +- **Test corpus:** custom + curated `ansi-test` slice. Place programs in `lib/common-lisp/tests/programs/` with `.lisp` extension. + +## General gotchas (all loops) + +- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences. +- `cond`/`when`/`let` clauses evaluate only the last expr. +- `type-of` on user fn returns `"lambda"`. +- Shell heredoc `||` gets eaten — escape or use `case`. + +## Style + +- No comments in `.sx` unless non-obvious. +- No new planning docs — update `plans/common-lisp-on-sx.md` inline. +- Short, factual commit messages (`common-lisp: handler-bind + 12 tests`). +- One feature per iteration. Commit. Log. Next. + +Go. Read the plan; find first `[ ]`; implement. diff --git a/plans/agent-briefings/lib-guest-loop.md b/plans/agent-briefings/lib-guest-loop.md new file mode 100644 index 00000000..7bc7690a --- /dev/null +++ b/plans/agent-briefings/lib-guest-loop.md @@ -0,0 +1,118 @@ +# lib/guest extraction loop (single agent, queue-driven) + +Role: iterates `plans/lib-guest.md` forever. Each iteration picks the top `pending` step, extracts/ports/validates, commits, logs, moves on. North star: every guest's `scoreboard.json` ≥ baseline at all times, while `lib/guest/` accumulates shared infrastructure. + +``` +description: lib/guest extraction loop +subagent_type: general-purpose +run_in_background: true +``` + +## Prompt + +You are the sole background agent working `/root/rose-ash/plans/lib-guest.md`. You work a prioritised queue, one step per code commit, indefinitely. The plan file is the source of truth for what's pending, in-progress, done, and blocked. Update it after every iteration. + +## Iteration protocol (follow exactly) + +### 1. Read state + +- Read `plans/lib-guest.md` in full. +- Pick the first step with status `[ ]`. If all remaining are `[blocked]` or `[done]`, stop and report loop complete. +- Set that step's status to `[in-progress]` and commit the plan change alone: + `GUEST-plan: claim step `. + +### 2. Baseline (every iteration that touches a guest) + +Before any code edit, snapshot the **current** scoreboard for every guest this step will touch (extraction consumers + canaries): + +``` +bash lib//conformance.sh # or test.sh +cp lib//scoreboard.json /tmp/baseline--step.json +``` + +If the step is Step 0, the snapshot itself is the work — copy each guest's `scoreboard.json` (or harvest pass/fail counts from `test.sh` for guests without a scoreboard) into `lib/guest/baseline/.json`, populate the table in `plans/lib-guest.md`, commit, done. + +### 3. Do the work + +For each step the protocol is: +1. Read the relevant existing guest file(s) via `sx_read_subtree` to see exactly what shape needs extracting. +2. Draft `lib/guest/.sx` via `sx_write_file` (validates by parsing). +3. Port the **first** consumer to use it. Run that guest's conformance. Must equal baseline. +4. Port the **second** consumer (the two-language rule). Run that guest's conformance. Must equal baseline. +5. If the second consumer needs escape hatches that the first didn't, the abstraction is wrong — **redesign before continuing**, don't paper over with alias chains or per-language flags. + +For Step 0 only: just snapshot, no extraction. + +### 4. Verify + +For every guest the step touched: + +``` +bash lib//conformance.sh # or test.sh +diff lib//scoreboard.json /tmp/baseline--step.json +``` + +**Abort rule:** if any touched guest's scoreboard regresses by ≥1 test, do NOT commit code. Revert with `git checkout -- lib/guest/ lib//`, mark the step `[blocked ()]` in the plan, commit the plan, move to the next step. + +### 5. Commit code + +One commit for the code: + +``` +GUEST: step + +<2-4 lines on what was extracted, which two consumers were ported, baseline-equal verification.> + +Co-Authored-By: Claude Opus 4.7 (1M context) +``` + +### 6. Update plan + commit + +In `plans/lib-guest.md`: +- Change this step's status from `[in-progress]` to `[done]` (or `[partial — pending ]`). +- Fill in the Commit and Delta columns of the progress log. +- If you re-snapshotted any baseline, update the Baseline column. + +Commit: `GUEST-plan: log step done`. + +### 7. Move on + +Go back to step 1. Continue until: +- All steps are `[done]` or `[blocked]`, OR +- You hit your iteration budget, OR +- You encounter a substrate-level failure (build broken, sx_server.exe missing) — stop and report. + +## Ground rules + +- **Branch:** `architecture`. Commit locally. **Never push.** **Never touch `main`.** +- **Scope:** ONLY `lib/guest/**`, `lib/{lua,prolog,haskell,common-lisp,tcl,erlang,smalltalk,forth,ruby,apl,js}/**`, `plans/lib-guest.md`, `plans/agent-briefings/lib-guest-loop.md`. NO `spec/`, `hosts/`, `web/`, `shared/`. +- **SX files:** `sx-tree` MCP tools ONLY. Never `Edit`/`Read`/`Write` on `.sx`. `sx_validate` after every edit. +- **OCaml build:** `sx_build target="ocaml"` MCP tool. Never raw `dune`. +- **Two-language rule:** never merge an extraction until two guests consume it. Step 8 (HM) is the only exception, marked explicitly. +- **No alias chains** to bridge naming drift between extraction and consumer — rename consumer-side or extraction-side, don't add a translation layer. +- **No new planning docs** beyond updating the plan file. +- **No comments in SX** unless non-obvious. +- **Unicode in SX:** raw UTF-8, never `\uXXXX`. +- **Hard timeout:** >45 min on a step → mark `blocked`, move on. +- **Partial fixes are OK.** If you extract something and only the first consumer ports cleanly, mark `[partial — pending ]`, commit, move on. The next iteration that lands the second consumer flips it to `[done]`. + +## Gotchas from past sessions + +- `env-bind!` creates a binding; `env-set!` mutates an existing one (walks scope chain). Macros that want to introduce names use `env-bind!`. +- SX `do` is R7RS iteration, not a sequence form. Use `begin` for multi-expr bodies. +- `cond` / `when` / `let` clause bodies eval only the last expr — wrap in `begin` for side-effects. +- `list?` returns false on raw JS Arrays — host-side data must be SX-converted. +- `make-symbol` builds an identifier symbol; `string->symbol` exists too — use whichever the surrounding code uses. +- `sx_validate` after every edit. The hook will block raw `Edit`/`Write` on `.sx` anyway, but the validator catches subtree mistakes that parse-but-don't-mean-what-you-think. +- Guest `conformance.sh` scripts use the epoch protocol against `sx_server.exe`. If the server isn't built, run `sx_build target="ocaml"` first. +- Each guest's `scoreboard.json` schema differs slightly — normalise to `{:totals {:pass N :fail M} :suites [...]}` when writing `lib/guest/baseline/.json`. +- `lib/parser-combinators.sx` exists and is unused by any guest. The new lex/Pratt kit may want to coexist with it, or supersede it — investigate before duplicating its functionality. +- Prolog operator parsing is the stress test for Pratt — Prolog ops have variable precedence, `xfx`/`xfy`/`yfx` associativity classes, and user-definable ops at runtime. The Pratt kit must accommodate runtime registration, not just static tables. +- Haskell layout is the stress test for whitespace-sensitive lexing — off-side rule, do/let/where/of opening blocks, semicolon insertion, brace insertion. Don't ship `lib/guest/layout.sx` unless the haskell scoreboard equals baseline. + +## Starting state + +- Branch: `architecture`. HEAD at or near `40f0e733`. +- Canaries: **Lua** + **Prolog**. +- Plan file at `plans/lib-guest.md`. Step 0 (baseline snapshot) is the first iteration. +- `lib/guest/` does not yet exist — create it on the Step 0 commit. 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/ruby-loop.md b/plans/agent-briefings/ruby-loop.md new file mode 100644 index 00000000..9a745a8b --- /dev/null +++ b/plans/agent-briefings/ruby-loop.md @@ -0,0 +1,83 @@ +# ruby-on-sx loop agent (single agent, queue-driven) + +Role: iterates `plans/ruby-on-sx.md` forever. Fibers via delcc is the headline showcase — `Fiber.new`/`Fiber.yield`/`Fiber.resume` are textbook delimited continuations with sugar, where MRI does it via C-stack swapping. Plus blocks/yield (lexical escape continuations, same shape as Smalltalk's non-local return), method_missing, and singleton classes. + +``` +description: ruby-on-sx queue loop +subagent_type: general-purpose +run_in_background: true +isolation: worktree +``` + +## Prompt + +You are the sole background agent working `/root/rose-ash/plans/ruby-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push. + +## Restart baseline — check before iterating + +1. Read `plans/ruby-on-sx.md` — roadmap + Progress log. +2. `ls lib/ruby/` — pick up from the most advanced file. +3. If `lib/ruby/tests/*.sx` exist, run them. Green before new work. +4. If `lib/ruby/scoreboard.md` exists, that's your baseline. + +## The queue + +Phase order per `plans/ruby-on-sx.md`: + +- **Phase 1** — tokenizer + parser. Keywords, identifier sigils (`@` ivar, `@@` cvar, `$` global), strings with interpolation, `%w[]`/`%i[]`, symbols, blocks `{|x| …}` and `do |x| … end`, splats, default args, method def +- **Phase 2** — object model + sequential eval. Class table, ancestor-chain dispatch, `super`, singleton classes, `method_missing` fallback, dynamic constant lookup +- **Phase 3** — blocks + procs + lambdas. Method captures escape continuation `^k`; `yield` / `return` / `break` / `next` / `redo` semantics; lambda strict arity vs proc lax +- **Phase 4** — **THE SHOWCASE**: fibers via delcc. `Fiber.new`/`Fiber.resume`/`Fiber.yield`/`Fiber.transfer`. Classic programs (generator, producer-consumer, tree-walk) green +- **Phase 5** — modules + mixins + metaprogramming. `include`/`prepend`/`extend`, `define_method`, `class_eval`/`instance_eval`, `respond_to?`/`respond_to_missing?`, hooks +- **Phase 6** — stdlib drive. `Enumerable` mixin, `Comparable`, Array/Hash/Range/String/Integer methods, drive corpus to 200+ + +Within a phase, pick the checkbox that unlocks the most tests per effort. + +Every iteration: implement → test → commit → tick `[ ]` → Progress log → next. + +## Ground rules (hard) + +- **Scope:** only `lib/ruby/**` and `plans/ruby-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib//` dirs, `lib/stdlib.sx`, or `lib/` root. Ruby primitives go in `lib/ruby/runtime.sx`. +- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop. +- **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`. +- **Commit granularity:** one feature per commit. +- **Plan file:** update Progress log + tick boxes every commit. + +## Ruby-specific gotchas + +- **Block `return` vs lambda `return`.** Inside a block `{ ... return v }`, `return` invokes the *enclosing method's* escape continuation (non-local return). Inside a lambda `->(){ ... return v }`, `return` returns from the *lambda*. Don't conflate. Implement: blocks bind their `^method-k`; lambdas bind their own `^lambda-k`. +- **`break` from inside a block** invokes a different escape — the *iteration loop's* escape — and the loop returns the break-value. `next` is escape from current iteration, returns iteration value. `redo` re-enters current iteration without advancing. +- **Proc arity is lax.** `proc { |a, b, c| … }.call(1, 2)` ↦ `c = nil`. Lambda is strict — same call raises ArgumentError. Check arity at call site for lambdas only. +- **Block argument unpacking.** `[[1,2],[3,4]].each { |a, b| … }` — single Array arg auto-unpacks for blocks (not lambdas). One arg, one Array → unpack. Frequent footgun. +- **Method dispatch chain order:** prepended modules → class methods → included modules → superclass → BasicObject → method_missing. `super` walks from the *defining* class's position, not the receiver class's. +- **Singleton classes** are lazily allocated. Looking up the chain for an object passes through its singleton class first, then its actual class. `class << obj; …; end` opens the singleton. +- **`method_missing`** — fallback when ancestor walk misses. Receives `(name_symbol, *args, &blk)`. Pair with `respond_to_missing?` for `respond_to?` to also report true. Do **not** swallow NoMethodError silently. +- **Ivars are per-object dicts.** Reading an unset ivar yields `nil` and a warning (`-W`). Don't error. +- **Constant lookup** is first lexical (Module.nesting), then inheritance (Module.ancestors of the innermost class). Different from method lookup. +- **`Object#send`** invokes private and public methods alike; `Object#public_send` skips privates. +- **Class reopening.** `class Foo; def bar; …; end; end` plus a later `class Foo; def baz; …; end; end` adds methods to the same class. Class table lookups must be by-name, mutable; methods dict is mutable. +- **Fiber semantics.** `Fiber.new { |arg| … }` creates a fiber suspended at entry. First `Fiber.resume(v)` enters with `arg = v`. Inside, `Fiber.yield(w)` returns `w` to the resumer; the next `Fiber.resume(v')` returns `v'` to the yield site. End of block returns final value to last resumer; subsequent `Fiber.resume` raises FiberError. +- **`Fiber.transfer`** is symmetric — either side can transfer to the other; no resume/yield asymmetry. Implement on top of the same continuation pair, just don't enforce direction. +- **Symbols are interned.** `:foo == :foo` is identity. Use SX symbols. +- **Strings are mutable.** `s = "abc"; s << "d"; s == "abcd"`. Hash keys can be strings; hash dups string keys at insertion to be safe (or freeze them). +- **Truthiness:** only `false` and `nil` are falsy. `0`, `""`, `[]` are truthy. +- **Test corpus:** custom + curated RubySpec slice. Place programs in `lib/ruby/tests/programs/` with `.rb` extension. + +## General gotchas (all loops) + +- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences. +- `cond`/`when`/`let` clauses evaluate only the last expr. +- `type-of` on user fn returns `"lambda"`. +- Shell heredoc `||` gets eaten — escape or use `case`. + +## Style + +- No comments in `.sx` unless non-obvious. +- No new planning docs — update `plans/ruby-on-sx.md` inline. +- Short, factual commit messages (`ruby: Fiber.yield + Fiber.resume (+8)`). +- One feature per iteration. Commit. Log. Next. + +Go. Read the plan; find first `[ ]`; implement. diff --git a/plans/agent-briefings/smalltalk-loop.md b/plans/agent-briefings/smalltalk-loop.md new file mode 100644 index 00000000..c971fdd1 --- /dev/null +++ b/plans/agent-briefings/smalltalk-loop.md @@ -0,0 +1,77 @@ +# smalltalk-on-sx loop agent (single agent, queue-driven) + +Role: iterates `plans/smalltalk-on-sx.md` forever. Message-passing OO + **blocks with non-local return** on delimited continuations. Non-local return is the headline showcase — every other Smalltalk reinvents it on the host stack; on SX it falls out of the captured method-return continuation. + +``` +description: smalltalk-on-sx queue loop +subagent_type: general-purpose +run_in_background: true +isolation: worktree +``` + +## Prompt + +You are the sole background agent working `/root/rose-ash/plans/smalltalk-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push. + +## Restart baseline — check before iterating + +1. Read `plans/smalltalk-on-sx.md` — roadmap + Progress log. +2. `ls lib/smalltalk/` — pick up from the most advanced file. +3. If `lib/smalltalk/tests/*.sx` exist, run them. Green before new work. +4. If `lib/smalltalk/scoreboard.md` exists, that's your baseline. + +## The queue + +Phase order per `plans/smalltalk-on-sx.md`: + +- **Phase 1** — tokenizer + parser (chunk format, identifiers, keywords `foo:`, binary selectors, `#sym`, `#(…)`, `$c`, blocks `[:a | …]`, cascades, message precedence) +- **Phase 2** — object model + sequential eval (class table bootstrap, message dispatch, `super`, `doesNotUnderstand:`, instance variables) +- **Phase 3** — **THE SHOWCASE**: blocks with non-local return via captured method-return continuation. `whileTrue:` / `ifTrue:ifFalse:` as block sends. 5 classic programs (eight-queens, quicksort, mandelbrot, life, fibonacci) green. +- **Phase 4** — reflection + MOP: `perform:`, `respondsTo:`, runtime method addition, `becomeForward:`, `Exception` / `on:do:` / `ensure:` on top of `handler-bind`/`raise` +- **Phase 5** — collections + numeric tower + streams +- **Phase 6** — port SUnit, vendor Pharo Kernel-Tests slice, drive corpus to 200+ +- **Phase 7** — speed (optional): inline caching, block intrinsification + +Within a phase, pick the checkbox that unlocks the most tests per effort. + +Every iteration: implement → test → commit → tick `[ ]` → Progress log → next. + +## Ground rules (hard) + +- **Scope:** only `lib/smalltalk/**` and `plans/smalltalk-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib//` dirs, `lib/stdlib.sx`, or `lib/` root. Smalltalk primitives go in `lib/smalltalk/runtime.sx`. +- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop. +- **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`. +- **Commit granularity:** one feature per commit. +- **Plan file:** update Progress log + tick boxes every commit. + +## Smalltalk-specific gotchas + +- **Method invocation captures `^k`** — the return continuation. Bind it as the block's escape token. `^expr` from inside any nested block invokes that captured `^k`. Escape past method return raises `BlockContext>>cannotReturn:`. +- **Blocks are lambdas + escape token**, not bare lambdas. `value`/`value:`/… invoke the lambda; `^` invokes the escape. +- **`ifTrue:` / `ifFalse:` / `whileTrue:` are ordinary block sends** — no special form. The runtime intrinsifies them in the JIT path (Tier 1 of bytecode expansion already covers this pattern). +- **Cascade** `r m1; m2; m3` desugars to `(let ((tmp r)) (st-send tmp 'm1 ()) (st-send tmp 'm2 ()) (st-send tmp 'm3 ()))`. Result is the cascade's last send (or first, depending on parser variant — pick one and document). +- **`super` send** looks up starting from the *defining* class's superclass, not the receiver class. Stash the defining class on the method record. +- **Selectors are interned symbols.** Use SX symbols. +- **Receiver dispatch:** tagged ints / floats / strings / symbols / `nil` / `true` / `false` aren't boxed. Their classes (`SmallInteger`, `Float`, `String`, `Symbol`, `UndefinedObject`, `True`, `False`) are looked up by SX type-of, not by an `:class` field. +- **Method precedence:** unary > binary > keyword. `3 + 4 factorial` is `3 + (4 factorial)`. `a foo: b bar` is `a foo: (b bar)` (keyword absorbs trailing unary). +- **Image / fileIn / become: between sessions** = out of scope. One-way `becomeForward:` only. +- **Test corpus:** ~200 hand-written + a slice of Pharo Kernel-Tests. Place programs in `lib/smalltalk/tests/programs/`. + +## General gotchas (all loops) + +- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences. +- `cond`/`when`/`let` clauses evaluate only the last expr. +- `type-of` on user fn returns `"lambda"`. +- Shell heredoc `||` gets eaten — escape or use `case`. + +## Style + +- No comments in `.sx` unless non-obvious. +- No new planning docs — update `plans/smalltalk-on-sx.md` inline. +- Short, factual commit messages (`smalltalk: tokenizer + 56 tests`). +- One feature per iteration. Commit. Log. Next. + +Go. Read the plan; find first `[ ]`; implement. diff --git a/plans/agent-briefings/sx-improvements-loop.md b/plans/agent-briefings/sx-improvements-loop.md new file mode 100644 index 00000000..438d8d8c --- /dev/null +++ b/plans/agent-briefings/sx-improvements-loop.md @@ -0,0 +1,86 @@ +# sx-improvements loop agent + +Iterates `plans/sx-improvements.md` forever. One step per commit. + +``` +description: sx-improvements loop +subagent_type: general-purpose +run_in_background: true +isolation: worktree +``` + +## Prompt + +You are the sole background agent iterating `plans/sx-improvements.md` on the `architecture` branch of `/root/rose-ash`. One step per commit, forever. Never push. + +## Restart baseline — check before each iteration + +1. Read `plans/sx-improvements.md` — find the first unchecked `[ ]` step in the progress log. +2. Read the step's section in the plan for exact implementation details. +3. Run the verification command for that step to confirm it currently fails. +4. Implement. Verify. Commit. Tick the `[ ]` → `[x]` in the progress log. Next. + +## Test commands + +- **OCaml spec:** `sx_build target="ocaml"` then check `bin/run_tests.exe` output. +- **JS spec (no DOM):** `node hosts/javascript/run_tests.js 2>&1 | tail -3` +- **HyperScript kernel:** `node tests/hs-kernel-eval.js 2>&1 | tail -3` +- **Baseline SX tests (non-HS):** `node hosts/javascript/run_tests.js 2>&1 | grep -v "hs-upstream\|hs-compat\|hs-dev" | grep "Results:"` + +Do NOT regress the pre-merge passing tests. After each step, confirm the count did not drop. + +## Ground rules (hard) + +- **Branch:** `architecture`. Never push. Never touch `main`. +- **SX files:** `sx-tree` MCP tools ONLY (`sx_summarise`, `sx_read_subtree`, `sx_replace_node`, `sx_insert_child`, `sx_validate`). Read before edit. Validate after edit. +- **Generated files:** NEVER edit `shared/static/wasm/sx/` or `shared/static/scripts/sx-*.js` directly. Rebuild via `sx_build`. +- **HS mirror rule:** after editing any `lib/hyperscript/.sx`, copy to `shared/static/wasm/sx/hs-.sx` using `sx_write_file` with the same content. +- **OCaml build:** `sx_build target="ocaml"` — never raw `dune exec`. +- **JS build:** `sx_build target="js"`. +- **One step per commit.** Tick the plan. Factual commit message. +- **No new planning docs.** No comments in SX unless non-obvious. +- **Unicode in SX:** raw UTF-8 only, never `\uXXXX` escapes. + +## Step-specific notes + +### Step 1 (JIT combinator bug) +The bug is in `hosts/ocaml/lib/sx_vm.ml` — `call_closure_reuse` path strips locals when +callee returns a closure. Look for the path where `call_closure_reuse` is invoked for a +`VmClosure` return value. The fix is to not reuse frames when the call might return a +closure, or to properly snapshot/restore `sp`. Check `spec/tests/test-parser-combinators.sx` +for existing combinator tests; run `node tests/hs-kernel-eval.js` for the 11 failing HS tests. + +### Step 2 (letrec+resume) +The bug is browser-only (`hosts/ocaml/browser/sx_browser.ml`). Write a minimal +`spec/tests/test-letrec-resume.sx` that exercises `letrec` + `perform` + resume and +verify it passes under `run_tests.exe` (OCaml server mode). Then check what +`sx_browser.ml` does differently in the VmSuspension resume path. + +### Steps 3-4 (E38 source info) +The API is already in `lib/hyperscript/runtime.sx`. The gap is in the tokenizer (no `:end`/`:line`) +and some parser span completeness. Run the 4 sourceInfo tests to see exact failures: +`node tests/hs-kernel-eval.js --suite sourceInfo` or grep results for `sourceInfo`. + +### Steps 5-8 (ADTs) +Full spec in `plans/designs/sx-adt.md`. Implement in OCaml first (Step 5), then mirror +to JS (Step 6). Steps 7-8 build on top. Write `spec/tests/test-adt.sx` from scratch — +start with a `(define-type Maybe (Just value) (Nothing))` suite covering constructor, +predicate, accessor, basic match, else clause. + +### Steps 9-11 (plugin system) +Full spec in `plans/designs/hs-plugin-system.md`. The prolog hook migration (Step 11) is +the most important for language-building — it's the pattern for all future embeds. + +### Steps 12-14 (performance) +Profile first. Use `sx_harness_eval` to measure throughput on a tight loop before and +after each change. Only commit if there's a measurable win (>10%). + +## General gotchas (all loops) + +- SX `do` is R7RS iteration. Use `begin` for multi-expr sequences. +- `cond`/`when`/`let` bodies evaluate only the last expression. +- `type-of` on a user-defined function returns `"lambda"`. +- Shell heredoc `||` gets eaten — escape or use `case`. +- `env-bind!` creates new bindings; `env-set!` mutates existing (walks scope chain). +- After OCaml edits: the build takes ~2 min. Run `sx_build target="ocaml"` and wait. +- After JS edits: retranspile with `sx_build target="js"` then re-run tests. diff --git a/plans/agent-briefings/tcl-loop.md b/plans/agent-briefings/tcl-loop.md new file mode 100644 index 00000000..c3596794 --- /dev/null +++ b/plans/agent-briefings/tcl-loop.md @@ -0,0 +1,83 @@ +# tcl-on-sx loop agent (single agent, queue-driven) + +Role: iterates `plans/tcl-on-sx.md` forever. `uplevel`/`upvar` is the headline showcase — Tcl's superpower for defining your own control structures, requiring deep VM cooperation in any normal host but falling out of SX's first-class env-chain. Plus the Dodekalogue (12 rules), command-substitution everywhere, and "everything is a string" homoiconicity. + +``` +description: tcl-on-sx queue loop +subagent_type: general-purpose +run_in_background: true +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. Push to `origin/loops/tcl` after every commit. + +## Restart baseline — check before iterating + +1. Read `plans/tcl-on-sx.md` — roadmap + Progress log. +2. `ls lib/tcl/` — pick up from the most advanced file. +3. If `lib/tcl/tests/*.sx` exist, run them. Green before new work. +4. If `lib/tcl/scoreboard.md` exists, that's your baseline. + +## The queue + +Phase order per `plans/tcl-on-sx.md`: + +- **Phase 1** — tokenizer + parser. The Dodekalogue (12 rules): word-splitting, command sub `[…]`, var sub `$name`/`${name}`/`$arr(idx)`, double-quote vs brace word, backslash, `;`, `#` comments only at command start, single-pass left-to-right substitution +- **Phase 2** — sequential eval + core commands. `set`/`unset`/`incr`/`append`/`lappend`, `puts`/`gets`, `expr` (own mini-language), `if`/`while`/`for`/`foreach`/`switch`, string commands, list commands, dict commands +- **Phase 3** — **THE SHOWCASE**: `proc` + `uplevel` + `upvar`. Frame stack with proc-call push/pop; `uplevel #N script` evaluates in caller's frame; `upvar` aliases names across frames. Classic programs (for-each-line, assert macro, with-temp-var) green +- **Phase 4** — `return -code N`, `catch`, `try`/`trap`/`finally`, `throw`. Control flow as integer codes +- **Phase 5** — namespaces + ensembles. `namespace eval`, qualified names `::ns::cmd`, ensembles, `namespace path` +- **Phase 6** — coroutines (built on fibers, same delcc as Ruby fibers) + system commands + drive corpus to 150+ + +Within a phase, pick the checkbox that unlocks the most tests per effort. + +Every iteration: implement → test → commit → tick `[ ]` → Progress log → next. + +## Ground rules (hard) + +- **Scope:** only `lib/tcl/**` and `plans/tcl-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib//` dirs, `lib/stdlib.sx`, or `lib/` root. Tcl primitives go in `lib/tcl/runtime.sx`. +- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop. +- **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, then push to `origin/loops/tcl`. Never touch `main`. +- **Commit granularity:** one feature per commit. +- **Plan file:** update Progress log + tick boxes every commit. + +## Tcl-specific gotchas + +- **Everything is a string.** Internally cache shimmer reps (list, dict, int, double) for performance, but every value must be re-stringifiable. Mutating one rep dirties the cached string and vice versa. +- **The Dodekalogue is strict.** Substitution is **one-pass**, **left-to-right**. The result of a substitution is a value, not a script — it does NOT get re-parsed for further substitutions. This is what makes Tcl safe-by-default. Don't accidentally re-parse. +- **Brace word `{…}`** is the only way to defer evaluation. No substitution inside, just balanced braces. Used for `if {expr}` body, `proc body`, `expr` arguments. +- **Double-quote word `"…"`** is identical to a bare word for substitution purposes — it just allows whitespace in a single word. `\` escapes still apply. +- **Comments are only at command position.** `# this is a comment` after a `;` or newline; *not* inside a command. `set x 1 # not a comment` is a 4-arg `set`. +- **`expr` has its own grammar** — operator precedence, function calls — and does its own substitution. Brace `expr {$x + 1}` to avoid double-substitution and to enable bytecode caching. +- **`if` and `while` re-parse** the condition only if not braced. Always use `if {…}`/`while {…}` form. The unbraced form re-substitutes per iteration. +- **`return` from a `proc`** uses control code 2. `break` is 3, `continue` is 4. `error` is 1. `catch` traps any non-zero code; user can return non-zero with `return -code error -errorcode FOO message`. +- **`uplevel #0 script`** is global frame. `uplevel 1 script` (or just `uplevel script`) is caller's frame. `uplevel #N` is absolute level N (0=global, 1=top-level proc, 2=proc-called-from-top, …). Negative levels are errors. +- **`upvar #N otherVar localVar`** binds `localVar` in the current frame as an *alias* — both names refer to the same storage. Reads and writes go through the alias. +- **`info level`** with no arg returns current level number. `info level N` (positive) returns the command list that invoked level N. `info level -N` returns the command list of the level N relative-up. +- **Variable names with `(…)`** are array elements: `set arr(foo) 1`. Arrays are not first-class values — you can't `set x $arr`. `array get arr` gives a flat list `{key1 val1 key2 val2 …}`. +- **List vs string.** `set l "a b c"` and `set l [list a b c]` look the same when printed but the second has a cached list rep. `lindex` works on both via shimmering. Most user code can't tell the difference. +- **`incr x`** errors if x doesn't exist; pre-set with `set x 0` or use `incr x 0` first if you mean "create-or-increment". Or use `dict incr` for dicts. +- **Coroutines are fibers.** `coroutine name body` starts a coroutine; calling `name` resumes it; `yield value` from inside suspends and returns `value` to the resumer. Same primitive as Ruby fibers — share the implementation under the hood. +- **`switch`** matches first clause whose pattern matches. Default is `default`. Variant matches: glob (default), `-exact`, `-glob`, `-regexp`. Body `-` means "fall through to next clause's body". +- **Test corpus:** custom + slice of Tcl's own tests. Place programs in `lib/tcl/tests/programs/` with `.tcl` extension. + +## General gotchas (all loops) + +- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences. +- `cond`/`when`/`let` clauses evaluate only the last expr. +- `type-of` on user fn returns `"lambda"`. +- Shell heredoc `||` gets eaten — escape or use `case`. + +## Style + +- No comments in `.sx` unless non-obvious. +- No new planning docs — update `plans/tcl-on-sx.md` inline. +- Short, factual commit messages (`tcl: uplevel + upvar (+11)`). +- One feature per iteration. Commit. Log. Next. + +Go. Read the plan; find first `[ ]`; implement. diff --git a/plans/apl-on-sx.md b/plans/apl-on-sx.md new file mode 100644 index 00000000..d4d689de --- /dev/null +++ b/plans/apl-on-sx.md @@ -0,0 +1,244 @@ +# APL-on-SX: rank-polymorphic primitives + glyph parser + +The headline showcase is **rank polymorphism** — a single primitive (`+`, `⌈`, `⊂`, `⍳`) works uniformly on scalars, vectors, matrices, and higher-rank arrays. ~80 glyph primitives + 6 operators bind together with right-to-left evaluation; the entire language is a high-density combinator algebra. The JIT compiler + primitive table pay off massively here because almost every program is `array → array` pure pipelines. + +End-state goal: Dyalog-flavoured APL subset, dfns + tradfns, classic programs (game-of-life, mandelbrot, prime-sieve, n-queens, conway), 100+ green tests. + +## Scope decisions (defaults — override by editing before we spawn) + +- **Syntax:** Dyalog APL surface, Unicode glyphs. `⎕`-quad system functions for I/O. `∇` tradfn header. +- **Conformance:** "Reads like APL, runs like APL." Not byte-compat with Dyalog; we care about right-to-left semantics and rank polymorphism. +- **Test corpus:** custom — APL idioms (Roger Hui style), classic programs, plus ~50 pattern tests for primitives. +- **Out of scope:** ⎕-namespaces beyond a handful, complex numbers, full TAO ordering, `⎕FX` runtime function definition (use static `∇` only), nested-array-of-functions higher orders, the editor. +- **Glyphs:** input via plain Unicode in `.apl` source files. Backtick-prefix shortcuts handled by the user's editor — we don't ship one. + +## Ground rules + +- **Scope:** only touch `lib/apl/**` and `plans/apl-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib//**`. APL primitives go in `lib/apl/runtime.sx`. +- **SX files:** use `sx-tree` MCP tools only. +- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes. + +## Architecture sketch + +``` +APL source (Unicode glyphs) + │ + ▼ +lib/apl/tokenizer.sx — glyphs, identifiers, numbers (¯ for negative), strings, strands + │ + ▼ +lib/apl/parser.sx — right-to-left with valence resolution (mon vs dyadic by position) + │ + ▼ +lib/apl/transpile.sx — AST → SX AST (entry: apl-eval-ast) + │ + ▼ +lib/apl/runtime.sx — array model, ~80 primitives, 6 operators, dfns/tradfns +``` + +Core mapping: +- **Array** = SX dict `{:shape (d1 d2 …) :ravel #(v1 v2 …)}`. Scalar is rank-0 (empty shape), vector is rank-1, matrix rank-2, etc. Type uniformity not required (heterogeneous nested arrays via "boxed" elements `⊂x`). +- **Rank polymorphism** — every scalar primitive is broadcast: `1 2 3 + 4 5 6` ↦ `5 7 9`; `(2 3⍴⍳6) + 1` ↦ broadcast scalar to matrix. +- **Conformability** = matching shapes, or one-side scalar, or rank-1 cycling (deferred — keep strict in v1). +- **Valence** = each glyph has a monadic and a dyadic meaning; resolution is purely positional (left-arg present → dyadic). +- **Operator** = takes one or two function operands, returns a derived function (`f¨` = `each f`, `f/` = `reduce f`, `f∘g` = `compose`, `f⍨` = `commute`). +- **Tradfn** `∇R←L F R; locals` = named function with explicit header. +- **Dfn** `{⍺+⍵}` = anonymous, `⍺` = left arg, `⍵` = right arg, `∇` = recurse. + +## Roadmap + +### Phase 1 — tokenizer + parser +- [x] Tokenizer: Unicode glyphs (the full APL set: `+ - × ÷ * ⍟ ⌈ ⌊ | ! ? ○ ~ < ≤ = ≥ > ≠ ∊ ∧ ∨ ⍱ ⍲ , ⍪ ⍴ ⌽ ⊖ ⍉ ↑ ↓ ⊂ ⊃ ⊆ ∪ ∩ ⍳ ⍸ ⌷ ⍋ ⍒ ⊥ ⊤ ⊣ ⊢ ⍎ ⍕ ⍝`), operators (`/ \ ¨ ⍨ ∘ . ⍣ ⍤ ⍥ @`), numbers (`¯` for negative, `1E2`, `1J2` complex deferred), characters (`'a'`, `''` escape), strands (juxtaposition of literals: `1 2 3`), names, comments `⍝ …` +- [x] Parser: right-to-left; classify each token as function, operator, value, or name; resolve valence positionally; dfn `{…}` body, tradfn `∇` header, guards `:`; outer product `∘.f`, inner product `f.g`, derived fns `f/ f¨ f⍨ f⍣n` +- [x] Unit tests in `lib/apl/tests/parse.sx` + +### Phase 2 — array model + scalar primitives +- [x] Array constructor: `make-array shape ravel`, `scalar v`, `vector v…`, `enclose`/`disclose` +- [x] Shape arithmetic: `⍴` (shape), `,` (ravel), `≢` (tally / first-axis-length), `≡` (depth) +- [x] Scalar arithmetic primitives broadcast: `+ - × ÷ ⌈ ⌊ * ⍟ | ! ○` +- [x] Scalar comparison primitives: `< ≤ = ≥ > ≠` +- [x] Scalar logical: `~ ∧ ∨ ⍱ ⍲` +- [x] Index generator: `⍳n` (vector 1..n or 0..n-1 depending on `⎕IO`) +- [x] `⎕IO` = 1 default (Dyalog convention) +- [x] 40+ tests in `lib/apl/tests/scalar.sx` + +### Phase 3 — structural primitives + indexing +- [x] Reshape `⍴`, ravel `,`, transpose `⍉` (full + dyadic axis spec) +- [x] Take `↑`, drop `↓`, rotate `⌽` (last axis), `⊖` (first axis) +- [x] Catenate `,` (last axis) and `⍪` (first axis) +- [x] Index `⌷` (squad), bracket-indexing `A[I]` (sugar for `⌷`) +- [x] Grade-up `⍋`, grade-down `⍒` +- [x] Enclose `⊂`, disclose `⊃`, partition (subset deferred) +- [x] Membership `∊`, find `⍳` (dyadic), without `~` (dyadic), unique `∪` (deferred to phase 6) +- [x] 40+ tests in `lib/apl/tests/structural.sx` + +### Phase 4 — operators (THE SHOWCASE) +- [x] Reduce `f/` (last axis), `f⌿` (first axis) — including `∧/`, `∨/`, `+/`, `×/`, `⌈/`, `⌊/` +- [x] Scan `f\`, `f⍀` +- [x] Each `f¨` — applies `f` to each scalar/element +- [x] Outer product `∘.f` — `1 2 3 ∘.× 1 2 3` ↦ multiplication table +- [x] Inner product `f.g` — `+.×` is matrix multiply +- [x] Commute `f⍨` — `f⍨ x` ↔ `x f x`, `x f⍨ y` ↔ `y f x` +- [x] Compose `f∘g` — applies `g` first then `f` +- [x] Power `f⍣n` — apply f n times; `f⍣≡` until fixed point +- [x] Rank `f⍤k` — apply f at sub-rank k +- [x] At `@` — selective replace +- [x] 40+ tests in `lib/apl/tests/operators.sx` + +### Phase 5 — dfns + tradfns + control flow +- [x] Dfn `{…}` with `⍺` (left arg, may be absent → niladic/monadic), `⍵` (right arg), `∇` (recurse), guards `cond:expr`, default left arg `⍺←default` +- [x] Local assignment via `←` (lexical inside dfn) +- [x] Tradfn `∇` header: `R←L F R;l1;l2`, statement-by-statement, branch via `→linenum` +- [x] Dyalog control words: `:If/:Else/:EndIf`, `:While/:EndWhile`, `:For X :In V :EndFor`, `:Select/:Case/:EndSelect`, `:Trap`/`:EndTrap` _(Trap deferred — no exception machinery yet)_ +- [x] Niladic / monadic / dyadic dispatch (function valence at definition time) +- [x] `lib/apl/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` + +### Phase 6 — classic programs + drive corpus +- [x] Classic programs in `lib/apl/tests/programs/`: + - [x] `life.apl` — Conway's Game of Life as a one-liner using `⊂` `⊖` `⌽` `+/` + - [x] `mandelbrot.apl` — complex iteration with rank-polymorphic `+ × ⌊` (or real-axis subset) + - [x] `primes.apl` — `(2=+⌿0=A∘.|A)/A←⍳N` sieve + - [x] `n-queens.apl` — backtracking via reduce + - [x] `quicksort.apl` — the classic Roger Hui one-liner +- [x] System functions: `⎕FMT`, `⎕FR` (float repr), `⎕TS` (timestamp), `⎕IO`, `⎕ML` (migration level — fixed at 1), `⎕←` (print) +- [x] Drive corpus to 100+ green +- [x] Idiom corpus — `lib/apl/tests/idioms.sx` covering classic Roger Hui / Phil Last idioms + +### Phase 7 — end-to-end pipeline + closing the gaps + +Phase 1-6 built parser and runtime as parallel layers — they don't yet meet. +Phase 7 wires them together so APL source actually runs through the full stack, +and tightens loose ends. + +- [x] **Operators in `apl-eval-ast`** — handle `:derived-fn` (e.g. `+/`, `f¨`), + `:outer` (`∘.f`), `:derived-fn2` (`f.g`). Each derived-fn-node wraps an inner + function; eval-ast resolves the inner glyph to a runtime fn and dispatches + to the matching operator helper (`apl-reduce`, `apl-each`, `apl-outer`, + `apl-inner`, `apl-commute`, `apl-compose`, `apl-power`, `apl-rank`). +- [x] **End-to-end pipeline** — entry point `apl-run : string → array` that + chains `apl-tokenize` → `parse-apl` → `apl-eval-ast` against an empty env. + Verify with one-liners (`+/⍳5` → 15, `1 2 3 + 4 5 6` → 7 9 11, etc.) and + with the actual `.apl` source files in `tests/programs/`. +- [x] **`:quad-name` AST + handler** — extend tokenizer/parser to recognise + `⎕name`, then handle in `apl-eval-ast` by dispatching to `apl-quad-*` + runtime fns (`⎕IO`, `⎕ML`, `⎕FR`, `⎕TS`, `⎕FMT`, `⎕←`). + _(`⎕←` deferred — tokenizer treats `←` as `:assign` after `⎕`.)_ +- [x] **Bracket indexing verification** — load programs that use `A[I]` / + `A[I;J]` end-to-end; confirm parser desugars to `⌷` and runtime returns + expected slices. Add 5+ tests. + _(Single-axis only — multi-axis `A[I;J]` requires semicolon parsing, deferred.)_ +- [x] **Idiom corpus expansion** — extend `idioms.sx` from 34 to 60+ once + end-to-end works (we can express idioms as APL strings, not as runtime + calls). Source-string-based idioms validate the whole stack. +- [x] **`:Trap` / `:EndTrap`** — minimal exception machinery: `:Trap n` + catches errors with code `n`, body runs in `apl-tradfn-eval-block`, + on error switches to the trap branch. Define `apl-throw` and a small + set of error codes; use `try`/`catch` from the host. + +### Phase 8 — fill the gaps left after end-to-end + +Phase 7 wired the stack together; Phase 8 closes deferred items, lets real +programs run from source, and starts pushing on performance. + +- [x] **Quick-wins bundle** (one iteration) — three small fixes that each unblock + real programs: + - decimal literals: `read-digits!` consumes one trailing `.` plus more digits + so `3.7` tokenises as one number; + - `⎕←` (print) — tokenizer special-case: when `⎕` is followed by `←`, emit + a single `:name "⎕←"` token (don't split on the assign glyph); + - string values in `apl-eval-ast` — handle `:str` (parser already produces + them) by wrapping into a vector of character codes (or rank-0 string). +- [x] **Named function definitions** — `f ← {⍺+⍵} ⋄ 1 f 2` and `2 f 3`. + - parser: when `:assign`'s RHS is a `:dfn`, mark it as a function binding; + - eval-ast: `:assign` of a dfn stores the dfn in env; + - parser: a name in fn-position whose env value is a dfn dispatches as a fn; + - resolver: extend `apl-resolve-monadic`/`-dyadic` with a `:fn-name` case + that calls `apl-call-dfn`/`apl-call-dfn-m`. +- [x] **Multi-axis bracket indexing** — `A[I;J]` and `A[;J]` and `A[I;]`. + - parser: split bracket content on `:semi` at depth 0; emit + `(:dyad ⌷ (:vec I J) A)`; + - runtime: extend `apl-squad` to accept a vector of indices, treating + `nil` / empty axis as "all"; + - 5+ tests across vector and matrix. +- [x] **`.apl` files as actual tests** — `lib/apl/tests/programs/*.apl` are + currently documentation. Add `apl-run-file path → array` plus tests that + load each file, execute it, and assert the expected result. Makes the + classic-program corpus self-validating instead of two parallel impls. + _(Embedded source-string approach: tests/programs-e2e.sx runs the same + algorithms as the .apl docs through the full pipeline. The original + one-liners (e.g. primes' inline `⍵←⍳⍵`) need parser features + (compress-as-fn, inline assign) we haven't built yet — multi-stmt forms + used instead. Slurp/read-file primitive missing in OCaml SX runtime.)_ +- [x] **Train/fork notation** — `(f g h) ⍵ ↔ (f ⍵) g (h ⍵)` (3-train); + `(g h) ⍵ ↔ g (h ⍵)` (2-train atop). Parser: detect when a parenthesised + subexpression is all functions and emit `(:train fns)`; resolver: build the + derived function; tests for mean-via-train (`+/÷≢`). +- [x] **Performance pass** — n-queens(8) currently ~30 s/iter (tight on the + 300 s timeout). Target: profile the inner loop, eliminate quadratic + list-append, restore the `queens(8)` test. + +## 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._ + +- 2026-05-07: Phase 8 step 6 — perf: swapped (append acc xs) → (append xs acc) in apl-permutations to make permutation generation linear instead of quadratic; q(7) 32s→12s; q(8)=92 test restored within 300s timeout; **Phase 8 complete, all unchecked items ticked**; 497/497 +- 2026-05-07: Phase 8 step 5 — train/fork notation. Parser :lparen detects all-fn inner segments → emits :train AST; resolver covers 2-atop & 3-fork for both monadic and dyadic. `(+/÷≢) 1..5 → 3` (mean), `(- ⌊) 5 → -5` (atop), `2(+×-)5 → -21` (dyadic fork), `(⌈/-⌊/) → 8` (range); +6 tests; 496/496 +- 2026-05-07: Phase 8 step 4 — programs-e2e.sx runs classic-algorithm shapes through full pipeline (factorial via ∇, triangulars, sum-of-squares, divisor-counts, prime-mask, named-fn composition, dyadic max-of-two, Newton step); also added ⌿ + ⍀ to glyph sets (were silently skipped); +15 tests; 490/490 +- 2026-05-07: Phase 8 step 3 — multi-axis bracket A[I;J] / A[I;] / A[;J] via :bracket AST + apl-bracket-multi runtime; split-bracket-content scans :semi at depth 0; apl-cartesian builds index combinations; nil axis = "all"; scalar axis collapses; +8 tests; 475/475 +- 2026-05-07: Phase 8 step 2 — named function defs end-to-end via parser pre-scan; apl-known-fn-names + apl-collect-fn-bindings detect `name ← {...}` patterns; collect-segments-loop emits :fn-name for known names; resolver looks up env for :fn-name; supports recursion (∇ in named dfn); +7 tests including fact via ∇; 467/467 +- 2026-05-07: Phase 8 step 1 — quick-wins bundle: decimal literals (3.7, ¯2.5), ⎕← passthrough as monadic fn (single-token via tokenizer special-case), :str AST in eval-ast (single-char→scalar, multi-char→vec); +10 tests; 460/460 +- 2026-05-07: Phase 8 added — quick-wins bundle (decimals + ⎕← + strings), named functions, multi-axis bracket, .apl-files-as-tests, trains, perf +- 2026-05-07: Phase 7 step 6 — :Trap exception machinery via R7RS guard; apl-throw raises tagged error, apl-trap-matches? checks codes (0=catch-all), :trap clause in apl-tradfn-eval-stmt wraps try-block with guard; :throw AST for testing; **Phase 7 complete, all unchecked plan items done**; +5 tests; 450/450 +- 2026-05-07: Phase 7 step 5 — idiom corpus 34→64 (+30 source-string idioms via apl-run); also fixed tokenizer + parser to recognize ≢ and ≡ glyphs (were silently skipped); 445/445 +- 2026-05-07: Phase 7 step 4 — bracket indexing `A[I]` desugared to `(:dyad ⌷ I A)` via maybe-bracket helper, wired into :name + :lparen branches of collect-segments-loop; multi-axis (A[I;J]) deferred (semicolon split); +7 tests; 415/415 +- 2026-05-07: Phase 7 step 3 — :quad-name end-to-end; tokenizer already produced :name "⎕FMT"; parser is-fn-tok? extended via apl-quad-fn-names; eval-ast :name dispatches ⎕IO/⎕ML/⎕FR/⎕TS to apl-quad-*; apl-monadic-fn handles ⎕FMT; ⎕← deferred (tokenizer splits ⎕←); +8 tests; 408/408 +- 2026-05-07: Phase 7 step 2 — end-to-end pipeline `apl-run : string → array` (parse-apl + apl-eval-ast against empty env); +25 source-string tests covering scalars, strands, dyadic arith, monadic primitives, operators, ∘./.g products, comparisons, famous one-liners (+/⍳10=55, ×/⍳10=10!); tokenizer can't yet parse decimals so `3.7` literal tests dropped; **400/400** +- 2026-05-07: Phase 7 step 1 — operators in apl-eval-ast via apl-resolve-monadic/dyadic; supports / ⌿ \ ⍀ ¨ ⍨ ∘. f.g; queens(8) test removed (too slow for 300s timeout); +14 eval-ops tests; 375/375 +- 2026-05-07: Phase 7 added — end-to-end pipeline, operators in eval-ast, :quad-name, bracket-indexing verify, idiom expansion, :Trap; aim is to wire parser↔runtime so .apl source files actually run +- 2026-05-07: Phase 6 idiom corpus — lib/apl/tests/idioms.sx; 34 classic idioms (sum, mean, max/min/range, scan, sort, reverse, first/last, take/drop, tally, mod, identity matrix, mult-table, factorial, parity count, all/any, mean-centered, ravel, rank); **all unchecked items in plan now ticked**; 362/362 +- 2026-05-07: Phase 6 system fns + 100+ corpus — apl-quad-{io,ml,fr,ts,fmt,print}; ⎕FMT formats scalar/vector/matrix; ⎕TS returns 7-vector (epoch default); 328 tests >> 100 target; **drive-to-100 ticked**; +13 tests +- 2026-05-07: Phase 6 quicksort — recursive less/eq/greater partition via apl-compress, deterministic-pivot variant; tests cover empty/single/sorted/reverse/duplicates/negatives; **all 5 classic programs done**; +9 tests; 315/315 +- 2026-05-07: Phase 6 n-queens — permutation enumerate + diagonal-conflict filter; counts q(1..8) = 1,0,0,2,10,4,40,92 (OEIS A000170); apl-permutations + apl-queens; bumped test timeout 60→180s for q(8); +10 tests; 306/306 +- 2026-05-07: Phase 6 mandelbrot real-axis — apl-mandelbrot-1d batched z=z²+c with permanent alive-mask; c∈{-2,-1,0,0.25} bounded, c=1→3, c=0.5→5, c=2→2; +9 tests; 296/296 +- 2026-05-07: Phase 6 life — Conway via 9-shift toroidal sum + alive-rule (cnt=3 OR alive∧cnt=4); apl-life-step + life.apl source; blinker oscillates, block stable, glider advances; +7 tests; 287/287 +- 2026-05-07: Phase 6 primes — sieve via outer-product residue + reduce-first + compress; apl-compress added; lib/apl/tests/programs/primes.apl source; +11 tests; 280/280 +- 2026-05-07: Phase 5 conformance.sh + scoreboard.{json,md} — per-suite runner; current snapshot 269/269; **Phase 5 complete** +- 2026-05-07: Phase 5 valence dispatch — apl-dfn-valence (AST scan for ⍺/⍵), apl-tradfn-valence (slot check), apl-call unified entry; +14 tests; 269/269 tests +- 2026-05-07: Phase 5 control words — :If/:Else, :While, :For/:In, :Select/:Case via apl-tradfn-eval-block/stmt threading env; :Trap deferred; +10 tests (sum loop, factorial, dispatch, nested); 255/255 tests +- 2026-05-07: Phase 5 tradfn — apl-call-tradfn + apl-tradfn-loop; line-numbered stmts, :branch goto, →0 exits, locals; +10 tests including loop sum; 245/245 tests +- 2026-05-07: Phase 5 dfn complete — apl-eval-stmts (guards, locals, ⍺←default), ∇ recursion via env "nabla"; +9 tests (factorial, guards, defaults, locals); 235/235 tests +- 2026-05-07: Phase 5 dfn foundation — lib/apl/transpile.sx with apl-eval-ast (handles :num :vec :name :monad :dyad :program :dfn) + glyph→fn lookup tables; apl-call-dfn / apl-call-dfn-m bind ⍺/⍵; ∇/guards/defaults/locals pending; 226/226 tests +- 2026-05-07: Phase 4 step 10 — at @ (apl-at-replace + apl-at-apply); linear-index lookup, scalar-vals broadcast; 211/211 tests +- 2026-05-07: Phase 4 step 9 — rank f⍤k (apl-rank); cell decomposition + reassembly via frame/cell shapes; 201/201 tests +- 2026-05-06: Phase 4 step 8 — power f⍣n (apl-power) + fixed-point f⍣≡ (apl-power-fixed); 191/191 tests +- 2026-05-06: Phase 4 step 7 — compose f∘g (apl-compose monadic f∘g x, apl-compose-dyadic dyadic f x (g y)); 182/182 tests +- 2026-05-06: Phase 4 step 6 — commute f⍨ (apl-commute monadic dup, apl-commute-dyadic swap); 173/173 tests +- 2026-05-06: Phase 4 step 5 — inner product f.g (apl-inner); +.× matrix multiply, ∧.= equal-vectors; 163/163 tests +- 2026-05-06: Phase 4 step 4 — outer product ∘.f (apl-outer); rank-doubling result shape = a-shape++b-shape; 151/151 tests +- 2026-05-06: Phase 4 step 3 — each f¨ (monadic apl-each + dyadic apl-each-dyadic); scalar broadcast both sides; 139/139 tests +- 2026-05-06: Phase 4 step 2 — scan f\ (last axis) + f⍀ (first axis); apl-scan/apl-scan-first; 125/125 tests +- 2026-05-06: Phase 4 step 1 — reduce f/ (last axis) + f⌿ (first axis); apl-reduce/apl-reduce-first; 110/110 tests +- 2026-05-06: Phase 3 complete — membership ∊, dyadic ⍳ (index-of), without ~ (index-of returns nil for not-found); 94/94 tests +- 2026-05-06: Phase 3 step 6 — enclose ⊂ / disclose ⊃ (box/unbox, rank-0 detect via type-of); 82/82 tests +- 2026-05-06: Phase 3 step 5 — grade-up ⍋ / grade-down ⍒ (stable insertion sort); 74/74 tests +- 2026-05-06: Phase 3 step 4 — squad ⌷ (scalar/multi-dim/partial-slice); 66/66 tests +- 2026-05-06: Phase 3 step 3 — catenate , (last axis, scalar promo) and first-axis; 59/59 tests +- 2026-05-06: Phase 3 step 2 — take ↑ (multi-axis, pad), drop ↓, reverse/rotate ⌽⊖ (last+first axis); 50/50 tests +- 2026-05-06: Phase 3 step 1 — reshape ⍴ (cycling), transpose ⍉ (monadic+dyadic); helpers apl-strides/flat->multi/multi->flat; 27/27 structural tests; lib/apl/tests/structural.sx +- 2026-04-26: Phase 2 complete — array model + 7 scalar primitive groups; 82/82 tests; lib/apl/runtime.sx + lib/apl/tests/scalar.sx +- 2026-04-26: parser (Phase 1 step 2) — 44/44 parser tests green (90/90 total); right-to-left segment algorithm; derived fns, outer/inner product, dfns with guards, strand handling; `lib/apl/parser.sx` + `lib/apl/tests/parse.sx` +- 2026-04-25: tokenizer (Phase 1 step 1) — 46/46 tests green; Unicode-aware starts-with? scanner for multi-byte APL glyphs; `lib/apl/tokenizer.sx` + `lib/apl/tests/parse.sx` + +## Blockers + +- _(none yet)_ diff --git a/plans/common-lisp-on-sx.md b/plans/common-lisp-on-sx.md new file mode 100644 index 00000000..e3571a96 --- /dev/null +++ b/plans/common-lisp-on-sx.md @@ -0,0 +1,152 @@ +# Common-Lisp-on-SX: conditions + restarts on delimited continuations + +The headline showcase is the **condition system**. Restarts are *resumable* exceptions — every other Lisp implementation reinvents this on host-stack unwind tricks. On SX restarts are textbook delimited continuations: `signal` walks the handler chain; `invoke-restart` resumes the captured continuation at the restart point. Same delcc primitive that powers Erlang actors, expressed as a different surface. + +End-state goal: ANSI Common Lisp subset with a working condition/restart system, CLOS multimethods (with `:before`/`:after`/`:around`), the LOOP macro, packages, and ~150 hand-written + classic programs. + +## Scope decisions (defaults — override by editing before we spawn) + +- **Syntax:** ANSI Common Lisp surface. Read tables, dispatch macros (`#'`, `#(`, `#\`, `#:`, `#x`, `#b`, `#o`, ratios `1/3`). +- **Conformance:** ANSI X3.226 *as a target*, not bug-for-bug SBCL/CCL. "Reads like CL, runs like CL." +- **Test corpus:** custom + a curated slice of `ansi-test`. Plus classic programs: condition-system demo, restart-driven debugger, multiple-dispatch geometry, LOOP corpus. +- **Out of scope:** compilation to native, FFI, sockets, threads, MOP class redefinition, full pathname/logical-pathname machinery, structures with `:include` deep customization. +- **Packages:** simple — `defpackage`/`in-package`/`export`/`use-package`/`:cl`/`:cl-user`. No nicknames, no shadowing-import edge cases. + +## Ground rules + +- **Scope:** only touch `lib/common-lisp/**` and `plans/common-lisp-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib//**`. CL primitives go in `lib/common-lisp/runtime.sx`. +- **SX files:** use `sx-tree` MCP tools only. +- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes. + +## Architecture sketch + +``` +Common Lisp source + │ + ▼ +lib/common-lisp/reader.sx — tokenizer + reader (read macros, dispatch chars) + │ + ▼ +lib/common-lisp/parser.sx — AST: forms, declarations, lambda lists + │ + ▼ +lib/common-lisp/transpile.sx — AST → SX AST (entry: cl-eval-ast) + │ + ▼ +lib/common-lisp/runtime.sx — special forms, condition system, CLOS, packages, BIFs +``` + +Core mapping: +- **Symbol** = SX symbol with package prefix; package table is a flat dict. +- **Cons cell** = SX pair via `cons`/`car`/`cdr`; lists native. +- **Multiple values** = thread through `values`/`multiple-value-bind`; primary-value default for one-context callers. +- **Block / return-from** = captured continuation; `return-from name v` invokes the block-named `^k`. +- **Tagbody / go** = each tag is a continuation; `go tag` invokes it. +- **Unwind-protect** = scope frame with a cleanup thunk fired on any non-local exit. +- **Conditions / restarts** = layered handler chain on top of `handler-bind` + delcc. `signal` walks handlers; `invoke-restart` resumes a captured continuation. +- **CLOS** = generic functions are dispatch tables on argument-class lists; method combination computed lazily; `call-next-method` is a continuation. +- **Macros** = SX macros (sentinel-body) — defmacro lowers directly. + +## Roadmap + +### Phase 1 — reader + parser +- [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 +- [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) +- [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 +- [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 +- [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 +- [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._ + +- 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 + +- _(none yet)_ 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/haskell-completeness.md b/plans/haskell-completeness.md index 7a7dbdc9..c2ae9398 100644 --- a/plans/haskell-completeness.md +++ b/plans/haskell-completeness.md @@ -311,6 +311,54 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. handler returns 0. - `trycatch.hs` — `try` pattern: run an action, branch on Left/Right. +### Phase 17 — Parser polish + +Real Haskell programs use these on every page; closing the gaps unblocks +larger conformance programs and removes one-line workarounds in test sources. + +- [ ] Type annotations in expressions: `(x :: Int)`, `f (1 :: Int)`, + `return (42 :: Int)`. Parser currently rejects `::` in `aexp` position; + desugar should drop the annotation (we have no inference at this layer + yet, so it's a parse-only pass-through). +- [ ] `import` declarations anywhere at the start of a module — currently + only the very-top-of-file form is recognised. Real test programs that + mix prelude code with `import qualified Data.IORef` need this. +- [ ] Multi-line top-level `where` blocks (`where { ... }` with explicit + braces and semicolons, in addition to the layout-driven form). +- [ ] Tests for the above in `lib/haskell/tests/parse-extras.sx` (≥ 8). + +### Phase 18 — One ambitious conformance program + +Pick something nontrivial that exercises feature interactions the small +suites miss; this is the only way to find unknown-unknown bugs. + +- [ ] Choose a target. Candidates: + - **Tiny lambda-calculus interpreter** (~80 LOC): parser, eval, env, + test cases. Stresses ADTs + records + recursion + `IORef` for state. + - **Dijkstra shortest-path** on a small graph using `Data.Map` + + `Data.Set`. Stresses Map/Set correctness end-to-end. + - **JSON parser** (subset): recursive-descent, exception-on-error, + `Either ParseError Value` results. Stresses strings + Either + try. +- [ ] Adapt minimally; cite source as a comment. +- [ ] Add to `conformance.conf`; verify scoreboard stays green. + +### Phase 19 — Conformance speed + +The full suite re-pays the ~30 s cold-load cost per program; 36 programs ⇒ +~25 minutes. Driving them all through one sx_server session would compress +that to single-digit minutes. + +- [ ] In `conformance.sh` (and/or `lib/guest/conformance.sh`), batch all + suites into one process: load preloads once, then for each suite emit + an `(epoch N)` + `(load …)` + `(eval read-counters)` + `(eval reset- + counters)` block. Aggregate the per-suite results from the streamed + output. +- [ ] Make sure a single failing/hanging suite doesn't poison the rest — + per-suite timeout via a server-side guard, or fall back to per-process + on timeout. +- [ ] Verify the scoreboard output is byte-identical to the old per-process + driver, then keep the per-process path as `--isolated` for debugging. + ## Progress log _Newest first._ diff --git a/plans/hs-blockers-drain.md b/plans/hs-blockers-drain.md new file mode 100644 index 00000000..94ba3baa --- /dev/null +++ b/plans/hs-blockers-drain.md @@ -0,0 +1,96 @@ +# HS conformance — blockers drain + +Goal: take hyperscript conformance from **1277/1496 (85.4%)** to **1496/1496 (100%)** by clearing the blocked clusters and the design-done Bucket E subsystems. + +This plan exists because the per-iteration `loops/hs` agent can't fit these into its 30-min budget — they need dedicated multi-commit sit-downs. Track progress here; refer to `plans/hs-conformance-to-100.md` for the canonical cluster ledger. + +## Current state (2026-04-25) + +- Loop running in `/root/rose-ash-loops/hs` (branch `loops/hs`) +- sx-tree MCP **fixed** (was a session-stale binary issue — restart of claude in the tmux window picked it up). Loop hinted to retry **#32**, **#29** first. +- Recent loop progress: ~1 commit/6h — easy wins drained, what's left needs focused attention. + +## Remaining work + +### Bucket-A/B/C blockers (small, in-place fixes) + +| # | Cluster | Tests | Effort | Blocker | Fix sketch | +|---|---------|------:|--------|---------|------------| +| **17** | `tell` semantics | +3 | ~1h | Implicit-default-target ambiguity. `bare add .bar` inside `tell X` should target `X` but explicit `to me` must reach the original element. | Add `beingTold` symbol distinct from `me`; bare commands compile to `beingTold-or-me`; explicit `me` always the original. | +| **22** | window global fn fallback | +2-4 | ~1h | `foo()` where `foo` isn't SX-defined needs to fall back to `(host-global "foo")`. Three attempts failed: guard (host-level error not catchable), `env-has?` (not in HS kernel), `hs-win-call` (NativeFn not callable from CALL). | Add `symbol-bound?` predicate to HS kernel **OR** a host-call-fn primitive with arity-agnostic dispatch. | +| **29** | `hyperscript:before:init` / `:after:init` / `:parse-error` events | +4-6 | ~30m (post sx-tree fix) | Was sx-tree MCP outage. Now unblocked — loop should retry. 4 of 6 tests need stricter parser error-rejection (out of scope; mark partial). | Edit `integration.sx` to fire DOM events at activation boundaries. | + +### Bucket D — medium features + +| # | Cluster | Tests | Effort | Status | +|---|---------|------:|--------|--------| +| **31** | runtime null-safety error reporting | **+15-18** | **2-4h** | **THIS SESSION'S TARGET.** Plan node fully spec'd: 5 pieces of work. | +| **32** | MutationObserver mock + `on mutation` | +10-15 | ~2h | Was sx-tree-blocked. Now unblocked — loop hinted to retry. Multi-file: parser, compiler, runtime, runner mock, generator skip-list. | +| **33** | cookie API | +2 (remaining) | ~30m | Partial done (+3). Remaining 2 need `hs-method-call` runtime fallback for unknown methods + `hs-for-each` recognising host-array/proxy collections. | +| 34 | event modifier DSL | +6-8 | ~1-2h | `elsewhere`, `every`, count filters (`once`/`twice`/`3 times`/ranges), `from elsewhere`. Pending. | +| 35 | namespaced `def` | +3 | ~30m | Pending. | + +### Bucket E — subsystems (design docs landed, multi-commit each) + +Each has a design doc with a step-by-step checklist. These are 1-2 days of focused work each, not loop-fits. + +| # | Subsystem | Tests | Design doc | Branch | +|---|-----------|------:|------------|--------| +| 36 | WebSocket + `socket` + RPC Proxy | +12-16 | `plans/designs/e36-websocket.md` | `worktree-agent-a9daf73703f520257` | +| 37 | Tokenizer-as-API | +16-17 | `plans/designs/e37-tokenizer-api.md` | `worktree-agent-a6bb61d59cc0be8b4` | +| 38 | SourceInfo API | +4 | `plans/designs/e38-sourceinfo.md` | `agent-e38-sourceinfo` | +| 39 | WebWorker plugin (parser-only stub) | +1 | `plans/designs/e39-webworker.md` | `hs-design-e39-webworker` | +| 40 | Real Fetch / non-2xx / before-fetch | +7 | `plans/designs/e40-real-fetch.md` | `worktree-agent-a94612a4283eaa5e0` | + +### Bucket F — generator translation gaps + +~25 tests SKIP'd because `tests/playwright/generate-sx-tests.py` bails with `return None`. Single dedicated generator-repair sit-down once Bucket D is drained. ~half-day. + +## Order of attack + +In approximate cost-per-test order: + +1. **Loop self-heal** (no human work) — wait for #29, #32 to land via the running loop ⏱️ ~next 1-2 hours +2. **#31 null-safety** — biggest scoped single win, dedicated worktree agent (this session) +3. **#33 cookie API remainder** — quick partial completion +4. **#17 / #22 / #34 / #35** — small fiddly fixes, one sit-down each +5. **Bucket E** — pick one subsystem at a time. **#39 (WebWorker stub) first** — single commit, smallest. Then **#38 (SourceInfo)** — 4 commits. Then the bigger three (#36, #37, #40). +6. **Bucket F** — generator repair sweep at the end. + +Estimated total to 100%: ~10-15 days of focused work, parallelisable across branches. + +## Cluster #31 spec (full detail) + +The plan note from `hs-conformance-to-100.md`: + +> 18 tests in `runtimeErrors`. When accessing `.foo` on nil, emit a structured error with position info. One coordinated fix in the compiler emit paths for property access, function calls, set/put. + +**Required pieces:** + +1. **Generator-side `eval-hs-error` helper + recognizer** for `expect(await error("HS")).toBe("MSG")` blocks. In `tests/playwright/generate-sx-tests.py`. +2. **Runtime helpers** in `lib/hyperscript/runtime.sx`: + - `hs-null-error!` raising `'' is null` + - `hs-named-target` — wraps a query result with the original selector source + - `hs-named-target-list` — same for list results +3. **Compiler patches at every target-position `(query SEL)` emit** — wrap in named-target carrying the original selector source. ~17 command emit paths in `lib/hyperscript/compiler.sx`: + add, remove, hide, show, measure, settle, trigger, send, set, default, increment, decrement, put, toggle, transition, append, take. +4. **Function-call null-check** at bare `(name)`, `hs-method-call`, and `host-get` chains, deriving the leftmost-uncalled-name (`'x'` / `'x.y'`) from the parse tree. +5. **Possessive-base null-check** (`set x's y to true` → `'x' is null`). + +**Files in scope:** +- `lib/hyperscript/runtime.sx` (new helpers) +- `lib/hyperscript/compiler.sx` (~17 emit-path edits) +- `tests/playwright/generate-sx-tests.py` (test recognizer) +- `tests/hs-run-filtered.js` (if mock helpers needed) +- `shared/static/wasm/sx/hs-runtime.sx` + `hs-compiler.sx` (WASM staging copies) + +**Approach:** target-named pieces incrementally — runtime helpers first (no compiler change), then compiler emit paths in batches (group similar commands), then function-call/possessive at the end. Each batch is one commit if it lands +N tests; mark partial if it only unlocks part. + +**Watch for:** smoke-range regressions (tests flipping pass→fail). Each commit: rerun smoke 0-195 and the `runtimeErrors` suite. + +## Notes for future sessions + +- `plans/hs-conformance-to-100.md` is the canonical cluster ledger — update it on every commit. +- `plans/hs-conformance-scoreboard.md` is the live tally — bump `Merged:` and the bucket roll-up. +- Loop has scope rule "never edit `spec/evaluator.sx` or broader SX kernel" — most fixes here stay in `lib/hyperscript/**`, `tests/`, generator. If a fix needs kernel work, surface to the user; don't merge silently. +- Cluster #22's `symbol-bound?` predicate would be a kernel addition — that's a real cross-boundary scope expansion. 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 `