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 index d89f3461..19198f22 100644 --- a/lib/smalltalk/runtime.sx +++ b/lib/smalltalk/runtime.sx @@ -1,370 +1,787 @@ -;; lib/smalltalk/runtime.sx — Smalltalk primitives on SX +;; Smalltalk runtime — class table, bootstrap hierarchy, type→class mapping, +;; instance construction. Method dispatch / eval-ast live in a later layer. ;; -;; Provides Smalltalk-idiomatic wrappers over SX built-ins. -;; Primitives used: -;; make-set/set-add!/set-member?/set-remove!/set->list (Phase 18) -;; char->integer/integer->char/list->string (Phase 5) -;; bitwise-and/or/xor/not/arithmetic-shift (Phase 7) -;; gcd/lcm/quotient/remainder/modulo (Phase 15) +;; 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!). -;; --------------------------------------------------------------------------- -;; 0. Internal list helpers (used by Array and Dictionary) -;; --------------------------------------------------------------------------- +(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-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))) + 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-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. Numeric helpers -;; Thin wrappers or direct aliases for Smalltalk Number protocol. -;; --------------------------------------------------------------------------- - -(define (st-abs x) (abs x)) -(define (st-max a b) (if (> a b) a b)) -(define (st-min a b) (if (< a b) a b)) -(define (st-gcd a b) (gcd a b)) -(define (st-lcm a b) (lcm a b)) -(define (st-quo a b) (quotient a b)) -(define (st-rem a b) (remainder a b)) -(define (st-mod a b) (modulo a b)) -(define (st-even? n) (= (remainder n 2) 0)) -(define (st-odd? n) (not (st-even? n))) -(define (st-sqrt x) (sqrt x)) -(define (st-floor x) (floor x)) -(define (st-ceiling x) (ceil x)) -(define (st-truncated x) (truncate x)) -(define (st-rounded x) (round x)) - -;; --------------------------------------------------------------------------- -;; 2. Character -;; Smalltalk $A = char 65. Operations mirror Character class. -;; --------------------------------------------------------------------------- - -(define (st-char-value c) (char->integer c)) -(define (st-char-from-int n) (integer->char n)) -(define (st-char? v) (= (type-of v) "char")) + st-ic-bump-generation! + (fn () (set! st-ic-generation (+ st-ic-generation 1)))) (define - (st-char-is-letter? c) - (let - ((n (char->integer c))) - (or - (and (>= n 65) (<= n 90)) - (and (>= n 97) (<= n 122))))) + st-method-cache-key + (fn (cls sel class-side?) (str cls "|" sel "|" (if class-side? "c" "i")))) (define - (st-char-is-digit? c) - (let ((n (char->integer c))) (and (>= n 48) (<= n 57)))) + st-method-cache-stats + (fn + () + {:hits st-method-cache-hits + :misses st-method-cache-misses + :size (len (keys st-method-cache))})) (define - (st-char-is-uppercase? c) - (let ((n (char->integer c))) (and (>= n 65) (<= n 90)))) + st-method-cache-reset-stats! + (fn () + (begin + (set! st-method-cache-hits 0) + (set! st-method-cache-misses 0)))) (define - (st-char-is-lowercase? c) - (let ((n (char->integer c))) (and (>= n 97) (<= n 122)))) + st-class-table-clear! + (fn () + (begin + (set! st-class-table {}) + (st-method-cache-clear!)))) (define - (st-char-is-separator? c) - (let - ((n (char->integer c))) - (or - (= n 32) - (= n 9) - (= n 10) - (= n 13)))) + 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-char-as-uppercase c) - (let - ((n (char->integer c))) - (if - (and (>= n 97) (<= n 122)) - (integer->char (- n 32)) - c))) + st-class-get + (fn (name) (if (has-key? st-class-table name) (get st-class-table name) nil))) (define - (st-char-as-lowercase c) - (let - ((n (char->integer c))) - (if - (and (>= n 65) (<= n 90)) - (integer->char (+ n 32)) - c))) - -(define (st-char-digit-value c) (- (char->integer c) 48)) - -;; --------------------------------------------------------------------------- -;; 3. Array (1-indexed, mutable, fixed-size) -;; Backed as {:__st_array__ true :size N "1" v1 "2" v2 ...} -;; Unset elements read as nil. -;; --------------------------------------------------------------------------- + st-class-exists? + (fn (name) (has-key? st-class-table name))) (define - (st-array-new n) - (let - ((a (dict))) - (dict-set! a "__st_array__" true) - (dict-set! a "size" n) - a)) - -(define (st-array? v) (and (dict? v) (dict-has? v "__st_array__"))) - -(define (st-array-size a) (get a "size")) - -(define - (st-array-at a i) - (let ((v (get a (str i)))) (if (= v nil) nil v))) - -(define (st-array-at-put! a i v) (dict-set! a (str i) v) a) - -(define - (st-array-do a fn) - (letrec - ((go (fn (i) (when (<= i (st-array-size a)) (fn (st-array-at a i)) (go (+ i 1)))))) - (go 1))) - -(define - (st-array->list a) - (letrec - ((go (fn (i acc) (if (< i 1) acc (go (- i 1) (cons (st-array-at a i) acc)))))) - (go (st-array-size a) (list)))) - -(define - (st-list->array xs) - (let - ((a (st-array-new (len xs)))) - (letrec - ((go (fn (ys i) (when (> (len ys) 0) (st-array-at-put! a i (first ys)) (go (rest ys) (+ i 1)))))) - (go xs 1)) - a)) - -(define - (st-array-copy-from-to a start stop) - (let - ((result (st-array-new (- stop start -1)))) - (letrec - ((go (fn (i j) (when (<= i stop) (st-array-at-put! result j (st-array-at a i)) (go (+ i 1) (+ j 1)))))) - (go start 1)) - result)) - -;; --------------------------------------------------------------------------- -;; 4. Dictionary (hash map with any key via linear scan) -;; {:__st_dict__ true :size N :_pairs ((key val) ...)} -;; --------------------------------------------------------------------------- - -(define - (st-dict-new) - (let - ((d (dict))) - (dict-set! d "__st_dict__" true) - (dict-set! d "size" 0) - (dict-set! d "_pairs" (list)) - d)) - -(define (st-dict? v) (and (dict? v) (dict-has? v "__st_dict__"))) - -(define (st-dict-size d) (get d "size")) - -(define - (st-dict-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 - (st-dict-at d k) - (letrec - ((go (fn (ps) (if (= (len ps) 0) nil (if (= (first (first ps)) k) (nth (first ps) 1) (go (rest ps))))))) - (go (get d "_pairs")))) - -(define - (st-dict-at-put! d k v) - (let - ((pairs (get d "_pairs")) (idx (st-dict-find-idx (get d "_pairs") k))) - (if - (= idx -1) - (begin - (dict-set! d "_pairs" (append pairs (list (list k v)))) - (dict-set! d "size" (+ (get d "size") 1))) - (dict-set! d "_pairs" (st-list-set-nth pairs idx (list k v))))) - d) - -(define - (st-dict-includes-key? d k) - (not (= (st-dict-find-idx (get d "_pairs") k) -1))) - -(define - (st-dict-at-default d k def) - (if (st-dict-includes-key? d k) (st-dict-at d k) def)) - -(define - (st-dict-remove-key! d k) - (let - ((idx (st-dict-find-idx (get d "_pairs") k))) - (when - (not (= idx -1)) - (dict-set! d "_pairs" (st-list-remove-nth (get d "_pairs") idx)) - (dict-set! d "size" (- (get d "size") 1)))) - d) - -(define (st-dict-keys d) (map first (get d "_pairs"))) -(define - (st-dict-values d) - (map (fn (p) (nth p 1)) (get d "_pairs"))) - -(define - (st-dict-do d fn) - (for-each (fn (p) (fn (nth p 1))) (get d "_pairs"))) - -(define - (st-dict-do-associations d fn) - (for-each (fn (p) (fn (first p) (nth p 1))) (get d "_pairs"))) - -;; --------------------------------------------------------------------------- -;; 5. Set (uniqueness via SX make-set) -;; Note: set-member?/set-add!/set-remove! take (set item) order. -;; --------------------------------------------------------------------------- - -(define - (st-set-new) - (let - ((s (dict))) - (dict-set! s "__st_set__" true) - (dict-set! s "size" 0) - (dict-set! s "_set" (make-set)) - s)) - -(define (st-set? v) (and (dict? v) (dict-has? v "__st_set__"))) - -(define (st-set-size s) (get s "size")) - -(define - (st-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 (st-set-includes? s v) (set-member? (get s "_set") v)) - -(define - (st-set-remove! 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 (st-set->list s) (set->list (get s "_set"))) - -(define (st-set-do s fn) (for-each fn (st-set->list s))) - -;; --------------------------------------------------------------------------- -;; 6. String / Stream utilities -;; --------------------------------------------------------------------------- - -;; Join list of strings with separator -(define - (st-join-strings strs sep) - (if - (= (len strs) 0) - "" - (letrec - ((go (fn (ss acc) (if (= (len ss) 0) acc (go (rest ss) (str acc sep (first ss))))))) - (go (rest strs) (first strs))))) - -;; printString — Smalltalk textual representation -(define - (st-print-string v) - (cond - ((= v nil) "nil") - ((= v true) "true") - ((= v false) "false") - ((= (type-of v) "number") (str v)) - ((= (type-of v) "string") (str "'" v "'")) - ((= (type-of v) "symbol") (str "#" (str v))) - ((= (type-of v) "char") (str "$" (list->string (list v)))) - ((= (type-of v) "list") - (str "(" (st-join-strings (map st-print-string v) " ") ")")) - ((st-array? v) - (str - "(#(" - (st-join-strings (map st-print-string (st-array->list v)) " ") - "))")) - (else (str v)))) - -;; WriteStream — accumulates strings/chars to a buffer -(define - (st-write-stream-new) - (let - ((ws (dict))) - (dict-set! ws "__st_ws__" true) - (dict-set! ws "contents" "") - ws)) - -(define (st-write-stream? v) (and (dict? v) (dict-has? v "__st_ws__"))) - -(define - (st-write-stream-put-string! ws s) - (dict-set! ws "contents" (str (get ws "contents") s)) - ws) - -(define - (st-write-stream-next-put! ws c) - (st-write-stream-put-string! ws (list->string (list c)))) - -(define - (st-write-stream-print! ws v) - (st-write-stream-put-string! ws (st-print-string v))) - -(define (st-write-stream-contents ws) (get ws "contents")) - -;; ReadStream — reads characters from a string one at a time -(define - (st-read-stream-new s) - (let - ((rs (dict))) - (dict-set! rs "__st_rs__" true) - (dict-set! rs "_chars" (string->list s)) - (dict-set! rs "pos" 0) - rs)) - -(define (st-read-stream? v) (and (dict? v) (dict-has? v "__st_rs__"))) - -(define - (st-read-stream-at-end? rs) - (>= (get rs "pos") (len (get rs "_chars")))) - -(define - (st-read-stream-next rs) - (if - (st-read-stream-at-end? rs) - nil + st-class-superclass + (fn + (name) (let - ((c (nth (get rs "_chars") (get rs "pos")))) - (dict-set! rs "pos" (+ (get rs "pos") 1)) - c))) + ((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-read-stream-peek rs) - (if - (st-read-stream-at-end? rs) - nil - (nth (get rs "_chars") (get rs "pos")))) + 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))))))) -(define (st-read-stream-source rs) (list->string (get rs "_chars"))) +;; Remove a method from a class (instance side). Mostly for tests; runtime +;; reflection in Phase 4 will use the same primitive. +(define + st-class-remove-method! + (fn + (cls-name selector) + (let ((cls (st-class-get cls-name))) + (cond + ((= cls nil) (error (str "st-class-remove-method!: unknown class " cls-name))) + (else + (let ((md (get cls :methods))) + (cond + ((not (has-key? md selector)) false) + (else + (let ((new-md {})) + (begin + (for-each + (fn (k) + (when (not (= k selector)) + (dict-set! new-md k (get md k)))) + (keys md)) + (set! + st-class-table + (assoc + st-class-table + cls-name + (assoc cls :methods new-md))) + (st-method-cache-clear!) + (st-ic-bump-generation!) + true)))))))))) + +;; Walk-only lookup. Returns the method record (with :defining-class) or nil. +;; class-side? = true searches :class-methods, false searches :methods. +(define + st-method-lookup-walk + (fn + (cls-name selector class-side?) + (let + ((found nil)) + (begin + (define + ml-loop + (fn + (cur) + (when + (and (= found nil) (not (= cur nil)) (st-class-exists? cur)) + (let + ((c (st-class-get cur))) + (let + ((dict (if class-side? (get c :class-methods) (get c :methods)))) + (cond + ((has-key? dict selector) (set! found (get dict selector))) + (else (ml-loop (get c :superclass))))))))) + (ml-loop cls-name) + found)))) + +;; Cached lookup. Misses are stored as :not-found so doesNotUnderstand paths +;; don't re-walk on every send. +(define + st-method-lookup + (fn + (cls-name selector class-side?) + (let ((key (st-method-cache-key cls-name selector class-side?))) + (cond + ((has-key? st-method-cache key) + (begin + (set! st-method-cache-hits (+ st-method-cache-hits 1)) + (let ((v (get st-method-cache key))) + (cond ((= v :not-found) nil) (else v))))) + (else + (begin + (set! st-method-cache-misses (+ st-method-cache-misses 1)) + (let ((found (st-method-lookup-walk cls-name selector class-side?))) + (begin + (set! + st-method-cache + (assoc + st-method-cache + key + (cond ((= found nil) :not-found) (else found)))) + found)))))))) + +;; SX value → Smalltalk class name. Native types are not boxed. +(define + st-class-of + (fn + (v) + (cond + ((= v nil) "UndefinedObject") + ((= v true) "True") + ((= v false) "False") + ((integer? v) "SmallInteger") + ((number? v) "Float") + ((string? v) "String") + ((symbol? v) "Symbol") + ((list? v) "Array") + ((and (dict? v) (has-key? v :type) (= (get v :type) "st-instance")) + (get v :class)) + ((and (dict? v) (has-key? v :type) (= (get v :type) "block")) + "BlockClosure") + ((and (dict? v) (has-key? v :st-block?) (get v :st-block?)) + "BlockClosure") + ((dict? v) "Dictionary") + ((lambda? v) "BlockClosure") + (else "Object")))) + +;; Construct a fresh instance of cls-name. Ivars (own + inherited) start as nil. +(define + st-make-instance + (fn + (cls-name) + (cond + ((not (st-class-exists? cls-name)) + (error (str "st-make-instance: unknown class " cls-name))) + (else + (let + ((iv-names (st-class-all-ivars cls-name)) (ivars {})) + (begin + (for-each (fn (n) (set! ivars (assoc ivars n nil))) iv-names) + {:type "st-instance" :class cls-name :ivars ivars})))))) + +(define + st-instance? + (fn + (v) + (and (dict? v) (has-key? v :type) (= (get v :type) "st-instance")))) + +(define + st-iv-get + (fn + (inst name) + (let ((ivs (get inst :ivars))) + (if (has-key? ivs name) (get ivs name) nil)))) + +(define + st-iv-set! + (fn + (inst name value) + (let + ((new-ivars (assoc (get inst :ivars) name value))) + (assoc inst :ivars new-ivars)))) + +;; Inherits-from check: is `descendant` either equal to `ancestor` or a subclass? +(define + st-class-inherits-from? + (fn + (descendant ancestor) + (let ((found false) (cur descendant)) + (begin + (define + ih-loop + (fn + () + (when + (and (not found) (not (= cur nil)) (st-class-exists? cur)) + (cond + ((= cur ancestor) (set! found true)) + (else + (begin + (set! cur (st-class-superclass cur)) + (ih-loop))))))) + (ih-loop) + found)))) + +;; Bootstrap the canonical class hierarchy. Reset and rebuild. +(define + st-bootstrap-classes! + (fn + () + (begin + (st-class-table-clear!) + ;; Root + (st-class-define! "Object" nil (list)) + ;; Class side machinery + (st-class-define! "Behavior" "Object" (list "superclass" "methodDict" "format")) + (st-class-define! "ClassDescription" "Behavior" (list "instanceVariables" "organization")) + (st-class-define! "Class" "ClassDescription" (list "name" "subclasses")) + (st-class-define! "Metaclass" "ClassDescription" (list "thisClass")) + ;; Pseudo-variable types + (st-class-define! "UndefinedObject" "Object" (list)) + (st-class-define! "Boolean" "Object" (list)) + (st-class-define! "True" "Boolean" (list)) + (st-class-define! "False" "Boolean" (list)) + ;; Magnitudes + (st-class-define! "Magnitude" "Object" (list)) + (st-class-define! "Number" "Magnitude" (list)) + (st-class-define! "Integer" "Number" (list)) + (st-class-define! "SmallInteger" "Integer" (list)) + (st-class-define! "LargePositiveInteger" "Integer" (list)) + (st-class-define! "Float" "Number" (list)) + (st-class-define! "Fraction" "Number" (list "numerator" "denominator")) + (st-class-define! "Character" "Magnitude" (list "value")) + ;; Collections + (st-class-define! "Collection" "Object" (list)) + (st-class-define! "SequenceableCollection" "Collection" (list)) + (st-class-define! "ArrayedCollection" "SequenceableCollection" (list)) + (st-class-define! "Array" "ArrayedCollection" (list)) + (st-class-define! "String" "ArrayedCollection" (list)) + (st-class-define! "Symbol" "String" (list)) + (st-class-define! "OrderedCollection" "SequenceableCollection" (list "array" "firstIndex" "lastIndex")) + ;; Hashed collection family + (st-class-define! "HashedCollection" "Collection" (list "array")) + (st-class-define! "Set" "HashedCollection" (list)) + ;; Blocks / contexts + (st-class-define! "BlockClosure" "Object" (list)) + ;; Reflection support — Message holds the selector/args for a DNU send. + (st-class-define! "Message" "Object" (list "selector" "arguments")) + (st-class-add-method! "Message" "selector" + (st-parse-method "selector ^ selector")) + (st-class-add-method! "Message" "arguments" + (st-parse-method "arguments ^ arguments")) + (st-class-add-method! "Message" "selector:" + (st-parse-method "selector: aSym selector := aSym")) + (st-class-add-method! "Message" "arguments:" + (st-parse-method "arguments: anArray arguments := anArray")) + ;; Exception hierarchy — Smalltalk's standard error system on top of + ;; SX's `guard`/`raise`. Subclassing Exception gives you on:do:, + ;; ensure:, ifCurtailed: catching out of the box. + (st-class-define! "Exception" "Object" (list "messageText")) + (st-class-add-method! "Exception" "messageText" + (st-parse-method "messageText ^ messageText")) + (st-class-add-method! "Exception" "messageText:" + (st-parse-method "messageText: aString messageText := aString. ^ self")) + (st-class-define! "Error" "Exception" (list)) + (st-class-define! "ZeroDivide" "Error" (list)) + (st-class-define! "MessageNotUnderstood" "Error" (list)) + ;; SequenceableCollection — shared iteration / inspection methods. + ;; Defined on the parent class so Array, String, Symbol, and + ;; OrderedCollection all inherit. Each method calls `self do:`, + ;; which dispatches to the receiver's primitive do: implementation. + (st-class-add-method! "SequenceableCollection" "inject:into:" + (st-parse-method + "inject: initial into: aBlock + | acc | + acc := initial. + self do: [:e | acc := aBlock value: acc value: e]. + ^ acc")) + (st-class-add-method! "SequenceableCollection" "detect:" + (st-parse-method + "detect: aBlock + self do: [:e | (aBlock value: e) ifTrue: [^ e]]. + ^ nil")) + (st-class-add-method! "SequenceableCollection" "detect:ifNone:" + (st-parse-method + "detect: aBlock ifNone: noneBlock + self do: [:e | (aBlock value: e) ifTrue: [^ e]]. + ^ noneBlock value")) + (st-class-add-method! "SequenceableCollection" "count:" + (st-parse-method + "count: aBlock + | n | + n := 0. + self do: [:e | (aBlock value: e) ifTrue: [n := n + 1]]. + ^ n")) + (st-class-add-method! "SequenceableCollection" "allSatisfy:" + (st-parse-method + "allSatisfy: aBlock + self do: [:e | (aBlock value: e) ifFalse: [^ false]]. + ^ true")) + (st-class-add-method! "SequenceableCollection" "anySatisfy:" + (st-parse-method + "anySatisfy: aBlock + self do: [:e | (aBlock value: e) ifTrue: [^ true]]. + ^ false")) + (st-class-add-method! "SequenceableCollection" "includes:" + (st-parse-method + "includes: target + self do: [:e | e = target ifTrue: [^ true]]. + ^ false")) + (st-class-add-method! "SequenceableCollection" "do:separatedBy:" + (st-parse-method + "do: aBlock separatedBy: sepBlock + | first | + first := true. + self do: [:e | + first ifFalse: [sepBlock value]. + first := false. + aBlock value: e]. + ^ self")) + (st-class-add-method! "SequenceableCollection" "indexOf:" + (st-parse-method + "indexOf: target + | idx | + idx := 1. + self do: [:e | e = target ifTrue: [^ idx]. idx := idx + 1]. + ^ 0")) + (st-class-add-method! "SequenceableCollection" "indexOf:ifAbsent:" + (st-parse-method + "indexOf: target ifAbsent: noneBlock + | idx | + idx := 1. + self do: [:e | e = target ifTrue: [^ idx]. idx := idx + 1]. + ^ noneBlock value")) + (st-class-add-method! "SequenceableCollection" "reject:" + (st-parse-method + "reject: aBlock ^ self select: [:e | (aBlock value: e) not]")) + (st-class-add-method! "SequenceableCollection" "isEmpty" + (st-parse-method "isEmpty ^ self size = 0")) + (st-class-add-method! "SequenceableCollection" "notEmpty" + (st-parse-method "notEmpty ^ self size > 0")) + ;; (no asString here — Symbol/String have their own primitive + ;; impls; SequenceableCollection-level fallback would overwrite + ;; the bare-name-for-Symbol behaviour.) + ;; Array class-side constructors for small fixed-arity literals. + (st-class-add-class-method! "Array" "with:" + (st-parse-method + "with: x | a | a := Array new: 1. a at: 1 put: x. ^ a")) + (st-class-add-class-method! "Array" "with:with:" + (st-parse-method + "with: a with: b + | r | r := Array new: 2. + r at: 1 put: a. r at: 2 put: b. ^ r")) + (st-class-add-class-method! "Array" "with:with:with:" + (st-parse-method + "with: a with: b with: c + | r | r := Array new: 3. + r at: 1 put: a. r at: 2 put: b. r at: 3 put: c. ^ r")) + (st-class-add-class-method! "Array" "with:with:with:with:" + (st-parse-method + "with: a with: b with: c with: d + | r | r := Array new: 4. + r at: 1 put: a. r at: 2 put: b. r at: 3 put: c. r at: 4 put: d. ^ r")) + ;; ── HashedCollection / Set / Dictionary ── + ;; Implemented as user instances with array-backed storage. Sets + ;; use a single `array` ivar; Dictionaries use parallel `keys`/ + ;; `values` arrays. New is class-side and routes through `init`. + (st-class-add-method! "HashedCollection" "init" + (st-parse-method "init array := Array new: 0. ^ self")) + (st-class-add-method! "HashedCollection" "size" + (st-parse-method "size ^ array size")) + (st-class-add-method! "HashedCollection" "isEmpty" + (st-parse-method "isEmpty ^ array isEmpty")) + (st-class-add-method! "HashedCollection" "notEmpty" + (st-parse-method "notEmpty ^ array notEmpty")) + (st-class-add-method! "HashedCollection" "do:" + (st-parse-method "do: aBlock array do: aBlock. ^ self")) + (st-class-add-method! "HashedCollection" "asArray" + (st-parse-method "asArray ^ array")) + (st-class-add-class-method! "Set" "new" + (st-parse-method "new ^ super new init")) + (st-class-add-method! "Set" "add:" + (st-parse-method + "add: anObject + (self includes: anObject) ifFalse: [array add: anObject]. + ^ anObject")) + (st-class-add-method! "Set" "addAll:" + (st-parse-method + "addAll: aCollection + aCollection do: [:e | self add: e]. + ^ aCollection")) + (st-class-add-method! "Set" "remove:" + (st-parse-method + "remove: anObject + array := array reject: [:e | e = anObject]. + ^ anObject")) + (st-class-add-method! "Set" "includes:" + (st-parse-method "includes: anObject ^ array includes: anObject")) + (st-class-define! "Dictionary" "HashedCollection" (list "keys" "values")) + (st-class-add-class-method! "Dictionary" "new" + (st-parse-method "new ^ super new init")) + (st-class-add-method! "Dictionary" "init" + (st-parse-method + "init keys := Array new: 0. values := Array new: 0. ^ self")) + (st-class-add-method! "Dictionary" "size" + (st-parse-method "size ^ keys size")) + (st-class-add-method! "Dictionary" "isEmpty" + (st-parse-method "isEmpty ^ keys isEmpty")) + (st-class-add-method! "Dictionary" "notEmpty" + (st-parse-method "notEmpty ^ keys notEmpty")) + (st-class-add-method! "Dictionary" "keys" + (st-parse-method "keys ^ keys")) + (st-class-add-method! "Dictionary" "values" + (st-parse-method "values ^ values")) + (st-class-add-method! "Dictionary" "at:" + (st-parse-method + "at: aKey + | i | + i := keys indexOf: aKey. + i = 0 ifTrue: [^ nil]. + ^ values at: i")) + (st-class-add-method! "Dictionary" "at:ifAbsent:" + (st-parse-method + "at: aKey ifAbsent: aBlock + | i | + i := keys indexOf: aKey. + i = 0 ifTrue: [^ aBlock value]. + ^ values at: i")) + (st-class-add-method! "Dictionary" "at:put:" + (st-parse-method + "at: aKey put: aValue + | i | + i := keys indexOf: aKey. + i = 0 + ifTrue: [keys add: aKey. values add: aValue] + ifFalse: [values at: i put: aValue]. + ^ aValue")) + (st-class-add-method! "Dictionary" "includesKey:" + (st-parse-method "includesKey: aKey ^ (keys indexOf: aKey) > 0")) + (st-class-add-method! "Dictionary" "removeKey:" + (st-parse-method + "removeKey: aKey + | i nk nv j | + i := keys indexOf: aKey. + i = 0 ifTrue: [^ nil]. + nk := Array new: 0. nv := Array new: 0. + j := 1. + [j <= keys size] whileTrue: [ + j = i ifFalse: [ + nk add: (keys at: j). + nv add: (values at: j)]. + j := j + 1]. + keys := nk. values := nv. + ^ aKey")) + (st-class-add-method! "Dictionary" "do:" + (st-parse-method "do: aBlock values do: aBlock. ^ self")) + (st-class-add-method! "Dictionary" "keysDo:" + (st-parse-method "keysDo: aBlock keys do: aBlock. ^ self")) + (st-class-add-method! "Dictionary" "valuesDo:" + (st-parse-method "valuesDo: aBlock values do: aBlock. ^ self")) + (st-class-add-method! "Dictionary" "keysAndValuesDo:" + (st-parse-method + "keysAndValuesDo: aBlock + | i | + i := 1. + [i <= keys size] whileTrue: [ + aBlock value: (keys at: i) value: (values at: i). + i := i + 1]. + ^ self")) + (st-class-define! "IdentityDictionary" "Dictionary" (list)) + ;; ── Stream hierarchy ── + ;; Streams wrap a collection with a 0-based `position`. Read/peek + ;; advance via `at:` (1-indexed Smalltalk-style) on the collection. + ;; Write streams require a mutable collection (Array works; String + ;; doesn't, see Phase 5 follow-up). + (st-class-define! "Stream" "Object" (list)) + (st-class-define! "PositionableStream" "Stream" (list "collection" "position")) + (st-class-define! "ReadStream" "PositionableStream" (list)) + (st-class-define! "WriteStream" "PositionableStream" (list)) + (st-class-define! "ReadWriteStream" "WriteStream" (list)) + (st-class-add-class-method! "ReadStream" "on:" + (st-parse-method "on: aColl ^ super new on: aColl")) + (st-class-add-class-method! "WriteStream" "on:" + (st-parse-method "on: aColl ^ super new on: aColl")) + (st-class-add-class-method! "WriteStream" "with:" + (st-parse-method + "with: aColl + | s | + s := super new on: aColl. + s setToEnd. + ^ s")) + (st-class-add-class-method! "ReadWriteStream" "on:" + (st-parse-method "on: aColl ^ super new on: aColl")) + (st-class-add-method! "PositionableStream" "on:" + (st-parse-method + "on: aColl collection := aColl. position := 0. ^ self")) + (st-class-add-method! "PositionableStream" "atEnd" + (st-parse-method "atEnd ^ position >= collection size")) + (st-class-add-method! "PositionableStream" "position" + (st-parse-method "position ^ position")) + (st-class-add-method! "PositionableStream" "position:" + (st-parse-method "position: n position := n. ^ self")) + (st-class-add-method! "PositionableStream" "reset" + (st-parse-method "reset position := 0. ^ self")) + (st-class-add-method! "PositionableStream" "setToEnd" + (st-parse-method "setToEnd position := collection size. ^ self")) + (st-class-add-method! "PositionableStream" "contents" + (st-parse-method "contents ^ collection")) + (st-class-add-method! "PositionableStream" "skip:" + (st-parse-method "skip: n position := position + n. ^ self")) + (st-class-add-method! "ReadStream" "next" + (st-parse-method + "next + self atEnd ifTrue: [^ nil]. + position := position + 1. + ^ collection at: position")) + (st-class-add-method! "ReadStream" "peek" + (st-parse-method + "peek + self atEnd ifTrue: [^ nil]. + ^ collection at: position + 1")) + (st-class-add-method! "ReadStream" "upToEnd" + (st-parse-method + "upToEnd + | result | + result := Array new: 0. + [self atEnd] whileFalse: [result add: self next]. + ^ result")) + (st-class-add-method! "ReadStream" "next:" + (st-parse-method + "next: n + | result i | + result := Array new: 0. + i := 0. + [(i < n) and: [self atEnd not]] whileTrue: [ + result add: self next. + i := i + 1]. + ^ result")) + (st-class-add-method! "WriteStream" "nextPut:" + (st-parse-method + "nextPut: anObject + collection add: anObject. + position := position + 1. + ^ anObject")) + (st-class-add-method! "WriteStream" "nextPutAll:" + (st-parse-method + "nextPutAll: aCollection + aCollection do: [:e | self nextPut: e]. + ^ aCollection")) + ;; ReadWriteStream inherits from WriteStream + ReadStream behaviour; + ;; for the simple linear-position model, both nextPut: and next work. + (st-class-add-method! "ReadWriteStream" "next" + (st-parse-method + "next + self atEnd ifTrue: [^ nil]. + position := position + 1. + ^ collection at: position")) + (st-class-add-method! "ReadWriteStream" "peek" + (st-parse-method + "peek + self atEnd ifTrue: [^ nil]. + ^ collection at: position + 1")) + ;; ── Fraction ── + ;; Rational numbers stored as numerator/denominator, normalized + ;; (sign on numerator, denominator > 0, reduced via gcd). + (st-class-add-class-method! "Fraction" "numerator:denominator:" + (st-parse-method + "numerator: n denominator: d + | f | + f := super new. + ^ f setNumerator: n denominator: d")) + (st-class-add-method! "Fraction" "setNumerator:denominator:" + (st-parse-method + "setNumerator: n denominator: d + | g s nn dd | + d = 0 ifTrue: [Error signal: 'Fraction denominator cannot be zero']. + s := (d < 0) ifTrue: [-1] ifFalse: [1]. + nn := n * s. dd := d * s. + g := nn abs gcd: dd. + g = 0 ifTrue: [g := 1]. + numerator := nn / g. + denominator := dd / g. + ^ self")) + (st-class-add-method! "Fraction" "numerator" + (st-parse-method "numerator ^ numerator")) + (st-class-add-method! "Fraction" "denominator" + (st-parse-method "denominator ^ denominator")) + (st-class-add-method! "Fraction" "+" + (st-parse-method + "+ other + ^ Fraction + numerator: numerator * other denominator + (other numerator * denominator) + denominator: denominator * other denominator")) + (st-class-add-method! "Fraction" "-" + (st-parse-method + "- other + ^ Fraction + numerator: numerator * other denominator - (other numerator * denominator) + denominator: denominator * other denominator")) + (st-class-add-method! "Fraction" "*" + (st-parse-method + "* other + ^ Fraction + numerator: numerator * other numerator + denominator: denominator * other denominator")) + (st-class-add-method! "Fraction" "/" + (st-parse-method + "/ other + ^ Fraction + numerator: numerator * other denominator + denominator: denominator * other numerator")) + (st-class-add-method! "Fraction" "negated" + (st-parse-method + "negated ^ Fraction numerator: numerator negated denominator: denominator")) + (st-class-add-method! "Fraction" "reciprocal" + (st-parse-method + "reciprocal ^ Fraction numerator: denominator denominator: numerator")) + (st-class-add-method! "Fraction" "=" + (st-parse-method + "= other + ^ numerator = other numerator and: [denominator = other denominator]")) + (st-class-add-method! "Fraction" "<" + (st-parse-method + "< other + ^ numerator * other denominator < (other numerator * denominator)")) + (st-class-add-method! "Fraction" "asFloat" + (st-parse-method "asFloat ^ numerator / denominator")) + (st-class-add-method! "Fraction" "printString" + (st-parse-method + "printString ^ numerator printString , '/' , denominator printString")) + (st-class-add-method! "Fraction" "isFraction" + (st-parse-method "isFraction ^ true")) + "ok"))) + +;; Initialise on load. Tests can re-bootstrap to reset state. +(st-bootstrap-classes!) diff --git a/lib/smalltalk/scoreboard.json b/lib/smalltalk/scoreboard.json new file mode 100644 index 00000000..a9149955 --- /dev/null +++ b/lib/smalltalk/scoreboard.json @@ -0,0 +1,15 @@ +{ + "date": "2026-04-25T16:05:32Z", + "programs": [ + "eight-queens.st", + "fibonacci.st", + "life.st", + "mandelbrot.st", + "quicksort.st" + ], + "program_count": 5, + "program_tests_passed": 39, + "all_tests_passed": 847, + "all_tests_total": 847, + "exit_code": 0 +} diff --git a/lib/smalltalk/scoreboard.md b/lib/smalltalk/scoreboard.md new file mode 100644 index 00000000..d479a276 --- /dev/null +++ b/lib/smalltalk/scoreboard.md @@ -0,0 +1,56 @@ +# Smalltalk-on-SX Scoreboard + +_Last run: 2026-04-25T16:05:32Z_ + +## Totals + +| Suite | Passing | +|-------|---------| +| All Smalltalk-on-SX tests | **847 / 847** | +| Classic-corpus tests (`tests/programs.sx`) | **39** | + +## Classic-corpus programs (`lib/smalltalk/tests/programs/`) + +| Program | Status | +|---------|--------| +| `eight-queens.st` | present | +| `fibonacci.st` | present | +| `life.st` | present | +| `mandelbrot.st` | present | +| `quicksort.st` | present | + +## Per-file test counts + +``` +OK lib/smalltalk/tests/ansi.sx 62 passed +OK lib/smalltalk/tests/blocks.sx 19 passed +OK lib/smalltalk/tests/cannot_return.sx 5 passed +OK lib/smalltalk/tests/collections.sx 29 passed +OK lib/smalltalk/tests/conditional.sx 25 passed +OK lib/smalltalk/tests/dnu.sx 15 passed +OK lib/smalltalk/tests/eval.sx 68 passed +OK lib/smalltalk/tests/exceptions.sx 15 passed +OK lib/smalltalk/tests/hashed.sx 30 passed +OK lib/smalltalk/tests/inline_cache.sx 10 passed +OK lib/smalltalk/tests/intrinsics.sx 24 passed +OK lib/smalltalk/tests/nlr.sx 14 passed +OK lib/smalltalk/tests/numbers.sx 47 passed +OK lib/smalltalk/tests/parse_chunks.sx 21 passed +OK lib/smalltalk/tests/parse.sx 47 passed +OK lib/smalltalk/tests/pharo.sx 91 passed +OK lib/smalltalk/tests/printing.sx 19 passed +OK lib/smalltalk/tests/programs.sx 39 passed +OK lib/smalltalk/tests/reflection.sx 77 passed +OK lib/smalltalk/tests/runtime.sx 64 passed +OK lib/smalltalk/tests/streams.sx 21 passed +OK lib/smalltalk/tests/sunit.sx 19 passed +OK lib/smalltalk/tests/super.sx 9 passed +OK lib/smalltalk/tests/tokenize.sx 63 passed +OK lib/smalltalk/tests/while.sx 14 passed +``` + +## Notes + +- The spec interpreter is correct but slow (call/cc + dict-based ivars per send). +- Larger Life multi-step verification, the 8-queens canonical case, and the glider-gun pattern are deferred to the JIT path. +- Generated by `bash lib/smalltalk/conformance.sh`. Both files are committed; the runner overwrites them on each run. diff --git a/lib/smalltalk/sunit.sx b/lib/smalltalk/sunit.sx new file mode 100644 index 00000000..50c5c862 --- /dev/null +++ b/lib/smalltalk/sunit.sx @@ -0,0 +1,153 @@ +;; SUnit — minimal port written in SX-Smalltalk, run by smalltalk-load. +;; +;; Provides: +;; TestCase — base class. Subclass it, add `testSomething` methods. +;; TestSuite — a collection of TestCase instances; runs them all. +;; TestResult — passes / failures / errors counts and lists. +;; TestFailure — Error subclass raised by `assert:` and friends. +;; +;; Conventions: +;; - Test methods are run in a fresh instance per test. +;; - `setUp` is sent before each test; `tearDown` after. +;; - Failures are signalled by TestFailure; runner catches and records. + +(define + st-sunit-source + "Error subclass: #TestFailure + instanceVariableNames: ''! + + Object subclass: #TestCase + instanceVariableNames: 'testSelector'! + + !TestCase methodsFor: 'access'! + testSelector ^ testSelector! + testSelector: aSym testSelector := aSym. ^ self! ! + + !TestCase methodsFor: 'fixture'! + setUp ^ self! + tearDown ^ self! ! + + !TestCase methodsFor: 'asserts'! + assert: aBoolean + aBoolean ifFalse: [TestFailure signal: 'assertion failed']. + ^ self! + + assert: aBoolean description: aString + aBoolean ifFalse: [TestFailure signal: aString]. + ^ self! + + assert: actual equals: expected + actual = expected ifFalse: [ + TestFailure signal: 'expected ' , expected printString + , ' but got ' , actual printString]. + ^ self! + + deny: aBoolean + aBoolean ifTrue: [TestFailure signal: 'denial failed']. + ^ self! + + should: aBlock raise: anExceptionClass + | raised | + raised := false. + [aBlock value] on: anExceptionClass do: [:e | raised := true]. + raised ifFalse: [ + TestFailure signal: 'expected exception ' , anExceptionClass name + , ' was not raised']. + ^ self! + + shouldnt: aBlock raise: anExceptionClass + | raised | + raised := false. + [aBlock value] on: anExceptionClass do: [:e | raised := true]. + raised ifTrue: [ + TestFailure signal: 'unexpected exception ' , anExceptionClass name]. + ^ self! ! + + !TestCase methodsFor: 'running'! + runCase + self setUp. + self perform: testSelector. + self tearDown. + ^ self! ! + + !TestCase class methodsFor: 'instantiation'! + selector: aSym ^ self new testSelector: aSym! + + suiteForAll: aSelectorArray + | suite | + suite := TestSuite new init. + suite name: self name. + aSelectorArray do: [:s | suite addTest: (self selector: s)]. + ^ suite! ! + + Object subclass: #TestResult + instanceVariableNames: 'passes failures errors'! + + !TestResult methodsFor: 'init'! + init + passes := Array new: 0. + failures := Array new: 0. + errors := Array new: 0. + ^ self! ! + + !TestResult methodsFor: 'access'! + passes ^ passes! + failures ^ failures! + errors ^ errors! + passCount ^ passes size! + failureCount ^ failures size! + errorCount ^ errors size! + totalCount ^ passes size + failures size + errors size! + + addPass: aTest passes add: aTest. ^ self! + addFailure: aTest message: aMsg + | rec | + rec := Array new: 2. + rec at: 1 put: aTest. rec at: 2 put: aMsg. + failures add: rec. + ^ self! + addError: aTest message: aMsg + | rec | + rec := Array new: 2. + rec at: 1 put: aTest. rec at: 2 put: aMsg. + errors add: rec. + ^ self! + + isEmpty ^ self totalCount = 0! + allPassed ^ (failures size + errors size) = 0! + + summary + ^ 'Tests: {1} Passed: {2} Failed: {3} Errors: {4}' + format: (Array + with: self totalCount printString + with: passes size printString + with: failures size printString + with: errors size printString)! ! + + Object subclass: #TestSuite + instanceVariableNames: 'tests name'! + + !TestSuite methodsFor: 'init'! + init tests := Array new: 0. name := 'Suite'. ^ self! + name ^ name! + name: aString name := aString. ^ self! ! + + !TestSuite methodsFor: 'tests'! + tests ^ tests! + addTest: aTest tests add: aTest. ^ self! + addAll: aCollection aCollection do: [:t | self addTest: t]. ^ self! + size ^ tests size! ! + + !TestSuite methodsFor: 'running'! + run + | result | + result := TestResult new init. + tests do: [:t | self runTest: t result: result]. + ^ result! + + runTest: aTest result: aResult + [aTest runCase. aResult addPass: aTest] + on: TestFailure do: [:e | aResult addFailure: aTest message: e messageText]. + ^ self! !") + +(smalltalk-load st-sunit-source) diff --git a/lib/smalltalk/test.sh b/lib/smalltalk/test.sh index 07e8a7ab..ce782993 100755 --- a/lib/smalltalk/test.sh +++ b/lib/smalltalk/test.sh @@ -1,71 +1,145 @@ #!/usr/bin/env bash -# lib/smalltalk/test.sh — smoke-test the Smalltalk runtime layer. -# Uses sx_server.exe epoch protocol. +# Fast Smalltalk-on-SX test runner — pipes directly to sx_server.exe. +# Mirrors lib/haskell/test.sh. # # Usage: -# bash lib/smalltalk/test.sh -# bash lib/smalltalk/test.sh -v +# 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="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +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 + 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="${1:-}" -TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT +VERBOSE="" +FILES=() +for arg in "$@"; do + case "$arg" in + -v|--verbose) VERBOSE=1 ;; + *) FILES+=("$arg") ;; + esac +done -cat > "$TMPFILE" << 'EPOCHS' +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" </dev/null) - -LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}') -if [ -z "$LINE" ]; then - LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \ - | sed -E 's/^\(ok 3 //; s/\)$//') -fi -if [ -z "$LINE" ]; then - echo "ERROR: could not extract summary" - echo "$OUTPUT" | tail -10 - exit 1 -fi - -P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/') -F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/') -TOTAL=$((P + F)) - -if [ "$F" -eq 0 ]; then - echo "ok $P/$TOTAL lib/smalltalk tests passed" -else - echo "FAIL $P/$TOTAL passed, $F failed" - # Print failure details - TMPFILE2=$(mktemp) - cat > "$TMPFILE2" << 'EPOCHS2' + else + cat > "$TMPFILE" </dev/null | grep -E '^\(ok 3 ' || true) - rm -f "$TMPFILE2" - echo " Failures: $FAILS" +(load "lib/smalltalk/runtime.sx") +(epoch 4) +(load "lib/smalltalk/eval.sx") +(epoch 5) +(load "lib/smalltalk/sunit.sx") +(epoch 6) +(load "lib/smalltalk/tests/tokenize.sx") +(epoch 7) +(load "$FILE") +(epoch 8) +(eval "(list st-test-pass st-test-fail)") +EPOCHS + fi + + OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>&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 -[ "$F" -eq 0 ] +[ $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 index 78dd4e5e..8398c64c 100644 --- a/lib/smalltalk/tests/runtime.sx +++ b/lib/smalltalk/tests/runtime.sx @@ -1,241 +1,255 @@ -;; lib/smalltalk/tests/runtime.sx — Tests for lib/smalltalk/runtime.sx +;; Smalltalk runtime tests — class table, type→class mapping, instances. ;; -;; Uses the same hk-test framework as lib/haskell/tests/runtime.sx. -;; Load: lib/smalltalk/runtime.sx first. +;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset +;; here so this file's summary covers runtime tests only. -;; --- Test framework --- -(define st-test-pass 0) -(define st-test-fail 0) -(define st-test-fails (list)) +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) -(define - (st-test name got expected) - (if - (= got expected) - (set! st-test-pass (+ st-test-pass 1)) - (begin - (set! st-test-fail (+ st-test-fail 1)) - (set! st-test-fails (append st-test-fails (list {:got got :expected expected :name name})))))) +;; Fresh hierarchy for every test file. +(st-bootstrap-classes!) -;; --------------------------------------------------------------------------- -;; 1. Numeric helpers -;; --------------------------------------------------------------------------- - -(st-test "abs -5" (st-abs -5) 5) -(st-test "abs 3" (st-abs 3) 3) -(st-test "max 3 7" (st-max 3 7) 7) -(st-test "min 3 7" (st-min 3 7) 3) -(st-test "gcd 12 8" (st-gcd 12 8) 4) -(st-test "lcm 4 6" (st-lcm 4 6) 12) -(st-test "quo 10 3" (st-quo 10 3) 3) -(st-test "quo -10 3" (st-quo -10 3) -3) -(st-test "rem 10 3" (st-rem 10 3) 1) -(st-test "rem -10 3" (st-rem -10 3) -1) -(st-test "mod 10 3" (st-mod 10 3) 1) -(st-test "mod -10 3" (st-mod -10 3) 2) -(st-test "even? 4" (st-even? 4) true) -(st-test "even? 3" (st-even? 3) false) -(st-test "odd? 7" (st-odd? 7) true) -(st-test "floor 3.7" (st-floor 3.7) 3) -(st-test "ceiling 3.2" (st-ceiling 3.2) 4) -(st-test "truncated 3.9" (st-truncated 3.9) 3) -(st-test "rounded 3.5" (st-rounded 3.5) 4) - -;; --------------------------------------------------------------------------- -;; 2. Character -;; --------------------------------------------------------------------------- - -(st-test - "char-value A" - (st-char-value (st-char-from-int 65)) - 65) -(st-test "char-from-int" (st-char? (st-char-from-int 65)) true) -(st-test "char? true" (st-char? (integer->char 65)) true) -(st-test "char? false" (st-char? 65) false) -(st-test "is-letter? A" (st-char-is-letter? (integer->char 65)) true) -(st-test - "is-letter? 1" - (st-char-is-letter? (integer->char 49)) - false) -(st-test "is-digit? 5" (st-char-is-digit? (integer->char 53)) true) -(st-test "is-digit? A" (st-char-is-digit? (integer->char 65)) false) -(st-test - "is-uppercase? A" - (st-char-is-uppercase? (integer->char 65)) +;; ── 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 - "is-uppercase? a" - (st-char-is-uppercase? (integer->char 97)) - false) -(st-test - "is-lowercase? a" - (st-char-is-lowercase? (integer->char 97)) +(st-test "SmallInteger / Float / Symbol exist" + (and + (st-class-exists? "SmallInteger") + (st-class-exists? "Float") + (st-class-exists? "Symbol")) true) -(st-test - "is-lowercase? A" - (st-char-is-lowercase? (integer->char 65)) - false) -(st-test - "is-separator? sp" - (st-char-is-separator? (integer->char 32)) - true) -(st-test - "is-separator? A" - (st-char-is-separator? (integer->char 65)) - false) -(st-test - "as-uppercase a" - (st-char-value (st-char-as-uppercase (integer->char 97))) - 65) -(st-test - "as-uppercase A" - (st-char-value (st-char-as-uppercase (integer->char 65))) - 65) -(st-test - "as-lowercase A" - (st-char-value (st-char-as-lowercase (integer->char 65))) - 97) -(st-test - "digit-value 5" - (st-char-digit-value (integer->char 53)) - 5) +(st-test "BlockClosure exists" (st-class-exists? "BlockClosure") true) -;; --------------------------------------------------------------------------- -;; 3. Array -;; --------------------------------------------------------------------------- +;; ── 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 - "array-new size" - (st-array-size (st-array-new 5)) - 5) -(st-test "array? yes" (st-array? (st-array-new 3)) true) -(st-test "array? no" (st-array? 42) false) + "method registered" + (has-key? (get (st-class-get "Account") :methods) "balance") + true) + (st-test - "array-at nil" - (st-array-at (st-array-new 3) 1) + "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) -(let - ((a (st-array-new 3))) - (st-array-at-put! a 1 10) - (st-array-at-put! a 2 20) - (st-array-at-put! a 3 30) - (st-test "array-at 1" (st-array-at a 1) 10) - (st-test "array-at 2" (st-array-at a 2) 20) - (st-test "array-at 3" (st-array-at a 3) 30)) +(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 - "list->array->list" - (st-array->list (st-list->array (list 1 2 3))) - (list 1 2 3)) + "subclass override picked first" + (get (st-method-lookup "SavingsAccount" "deposit:" false) :defining-class) + "SavingsAccount") -(let - ((a (st-list->array (list 10 20 30 40 50)))) - (st-test - "copy-from-to" - (st-array->list (st-array-copy-from-to a 2 4)) - (list 20 30 40))) +(st-test + "Account still finds its own deposit:" + (get (st-method-lookup "Account" "deposit:" false) :defining-class) + "Account") -;; --------------------------------------------------------------------------- -;; 4. Dictionary -;; --------------------------------------------------------------------------- +;; ── 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) -(st-test "dict? yes" (st-dict? (st-dict-new)) true) -(st-test "dict? no" (st-dict? 42) false) -(st-test "dict empty size" (st-dict-size (st-dict-new)) 0) -(st-test "dict at absent" (st-dict-at (st-dict-new) "k") 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) -(let - ((d (st-dict-new))) - (st-dict-at-put! d "a" 1) - (st-dict-at-put! d "b" 2) - (st-test "dict at a" (st-dict-at d "a") 1) - (st-test "dict at b" (st-dict-at d "b") 2) - (st-test "dict size 2" (st-dict-size d) 2) - (st-test "includes-key? yes" (st-dict-includes-key? d "a") true) - (st-test "includes-key? no" (st-dict-includes-key? d "z") false) - (st-dict-at-put! d "a" 99) - (st-test "dict update" (st-dict-at d "a") 99) - (st-test "size unchanged" (st-dict-size d) 2) - (st-dict-remove-key! d "a") - (st-test "size after remove" (st-dict-size d) 1) - (st-test "at-default hit" (st-dict-at-default d "b" 0) 2) - (st-test "at-default miss" (st-dict-at-default d "z" -1) -1)) +;; ── 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")) -;; --------------------------------------------------------------------------- -;; 5. Set -;; --------------------------------------------------------------------------- +;; Bootstrap clears cache; record stats from now. +(st-method-cache-reset-stats!) -(st-test "set? yes" (st-set? (st-set-new)) true) -(st-test "set? no" (st-set? 42) false) -(st-test "set empty size" (st-set-size (st-set-new)) 0) +;; 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) -(let - ((s (st-set-new))) - (st-set-add! s 1) - (st-set-add! s 2) - (st-set-add! s 1) - (st-test "set includes 1" (st-set-includes? s 1) true) - (st-test "set includes 2" (st-set-includes? s 2) true) - (st-test "set not includes 3" (st-set-includes? s 3) false) - (st-test "set dedup size" (st-set-size s) 2) - (st-set-remove! s 1) - (st-test "size after remove" (st-set-size s) 1) - (st-test "removed gone" (st-set-includes? s 1) false)) +(st-method-lookup "Bar" "greet" false) +(st-test + "second lookup hits cache" + (get (st-method-cache-stats) :hits) + 1) -;; --------------------------------------------------------------------------- -;; 6. String / Stream -;; --------------------------------------------------------------------------- +;; 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) -(st-test "join-strings 3" (st-join-strings (list "a" "b" "c") "-") "a-b-c") -(st-test "join-strings 1" (st-join-strings (list "x") ",") "x") -(st-test "join-strings empty" (st-join-strings (list) ",") "") +;; 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") -(st-test "print nil" (st-print-string nil) "nil") -(st-test "print true" (st-print-string true) "true") -(st-test "print false" (st-print-string false) "false") -(st-test "print number" (st-print-string 42) "42") -(st-test "print string" (st-print-string "hi") "'hi'") -(st-test "print char" (st-print-string (integer->char 65)) "$A") -(st-test "print list" (st-print-string (list 1 2)) "(1 2)") +;; 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") -(let - ((ws (st-write-stream-new))) - (st-write-stream-put-string! ws "hello") - (st-write-stream-put-string! ws " world") - (st-test - "write-stream contents" - (st-write-stream-contents ws) - "hello world")) +;; 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) -(let - ((ws (st-write-stream-new))) - (st-write-stream-next-put! ws (integer->char 72)) - (st-write-stream-next-put! ws (integer->char 105)) - (st-test "write-stream next-put!" (st-write-stream-contents ws) "Hi")) - -(let - ((rs (st-read-stream-new "ABC"))) - (st-test - "read-stream next A" - (st-char-value (st-read-stream-next rs)) - 65) - (st-test - "read-stream next B" - (st-char-value (st-read-stream-next rs)) - 66) - (st-test - "read-stream peek C" - (st-char-value (st-read-stream-peek rs)) - 67) - (st-test - "read-stream next C" - (st-char-value (st-read-stream-next rs)) - 67) - (st-test "read-stream at-end" (st-read-stream-at-end? rs) true)) - -;; --------------------------------------------------------------------------- -;; Summary (must be last form — test.sh reads this) -;; --------------------------------------------------------------------------- +;; 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/plans/smalltalk-on-sx.md b/plans/smalltalk-on-sx.md index 2d4f47f1..43e8f399 100644 --- a/plans/smalltalk-on-sx.md +++ b/plans/smalltalk-on-sx.md @@ -50,64 +50,100 @@ Core mapping: ## Roadmap ### Phase 1 — tokenizer + parser -- [ ] Tokenizer: identifiers, keywords (`foo:`), binary selectors (`+`, `==`, `,`, `->`, `~=` etc.), numbers (radix `16r1F`, scaled `1.5s2`), strings `'…''…'`, characters `$c`, symbols `#foo` `#'foo bar'` `#+`, byte arrays `#[1 2 3]`, literal arrays `#(1 #foo 'x')`, comments `"…"` -- [ ] Parser: chunk format (`! !` separators), class definitions (`Object subclass: #X instanceVariableNames: '…' classVariableNames: '…' …`), method definitions (`extend: #Foo with: 'bar ^self'`), pragmas ``, blocks `[:a :b | | t1 t2 | …]`, cascades, message precedence (unary > binary > keyword) -- [ ] Unit tests in `lib/smalltalk/tests/parse.sx` +- [x] Tokenizer: identifiers, keywords (`foo:`), binary selectors (`+`, `==`, `,`, `->`, `~=` etc.), numbers (radix `16r1F`; **scaled `1.5s2` deferred**), strings `'…''…'`, characters `$c`, symbols `#foo` `#'foo bar'` `#+`, byte arrays `#[1 2 3]` (open token), literal arrays `#(1 #foo 'x')` (open token), comments `"…"` +- [x] Parser (expression level): blocks `[:a :b | | t1 t2 | …]`, cascades, message precedence (unary > binary > keyword), assignment, return, statement sequences, literal arrays, byte arrays, paren grouping, method headers (`+ other`, `at:put:`, unary, with temps and body). Class-definition keyword messages parse as ordinary keyword sends — no special-case needed. +- [x] Parser (chunk-stream level): `st-read-chunks` splits source on `!` (with `!!` doubling) and `st-parse-chunks` runs the Pharo file-in state machine — `methodsFor:` / `class methodsFor:` opens a method batch, an empty chunk closes it. Pragmas `` (incl. multiple keyword pairs, before or after temps, multiple per method) parsed into the method AST. +- [x] Unit tests in `lib/smalltalk/tests/parse.sx` ### Phase 2 — object model + sequential eval -- [ ] Class table + bootstrap: `Object`, `Behavior`, `Class`, `Metaclass`, `UndefinedObject`, `Boolean`/`True`/`False`, `Number`/`Integer`/`Float`, `String`, `Symbol`, `Array`, `Block` -- [ ] `smalltalk-eval-ast`: literals, variable reference, assignment, message send, cascade, sequence, return -- [ ] Method lookup: walk class → superclass; cache hit-class on `(class, selector)` -- [ ] `doesNotUnderstand:` fallback constructing `Message` object -- [ ] `super` send (lookup starts at superclass of *defining* class, not receiver class) -- [ ] 30+ tests in `lib/smalltalk/tests/eval.sx` +- [x] Class table + bootstrap (`lib/smalltalk/runtime.sx`): canonical hierarchy installed (`Object`, `Behavior`, `ClassDescription`, `Class`, `Metaclass`, `UndefinedObject`, `Boolean`/`True`/`False`, `Magnitude`/`Number`/`Integer`/`SmallInteger`/`Float`/`Character`, `Collection`/`SequenceableCollection`/`ArrayedCollection`/`Array`/`String`/`Symbol`/`OrderedCollection`/`Dictionary`, `BlockClosure`). User class definition via `st-class-define!`, methods via `st-class-add-method!` (stamps `:defining-class` for super), method lookup walks chain, ivars accumulated through superclass chain, native SX value types map to Smalltalk classes via `st-class-of`. +- [x] `smalltalk-eval-ast` (`lib/smalltalk/eval.sx`): all literal kinds, ident resolution (locals → ivars → class refs), self/super/thisContext, assignment (locals or ivars, mutating), message send, cascade, sequence, and ^return via a sentinel marker (proper continuation-based escape is the Phase 3 showcase). Frames carry a parent chain so blocks close over outer locals. Primitive method tables for SmallInteger/Float, String/Symbol, Boolean, UndefinedObject, Array, BlockClosure (value/value:/whileTrue:/etc.), and class-side `new`/`name`/etc. Also satisfies "30+ tests" — 60 eval tests. +- [x] Method lookup: walk class → superclass already in `st-method-lookup-walk`; new cached wrapper `st-method-lookup` keys on `(class, selector, side)` and stores `:not-found` for negative results so DNU paths don't re-walk. Cache invalidates on `st-class-define!`, `st-class-add-method!`, `st-class-add-class-method!`, `st-class-remove-method!`, and full bootstrap. Stats helpers `st-method-cache-stats` / `st-method-cache-reset-stats!` for tests + later debugging. +- [x] `doesNotUnderstand:` fallback. `Message` class added at bootstrap with `selector`/`arguments` ivars and accessor methods. Primitive senders (Number/String/Boolean/Nil/Array/BlockClosure/class-side) now return the `:unhandled` sentinel for unknown selectors; `st-send` builds a `Message` via `st-make-message` and routes through `st-dnu`, which looks up `doesNotUnderstand:` on the receiver's class chain (instance- or class-side as appropriate). User overrides intercept unknowns and see the symbol selector + arguments array in the Message. +- [x] `super` send. Method invocation captures the defining class on the frame; `st-super-send` walks from `(st-class-superclass defining-class)` (instance- or class-side as appropriate). Falls through primitives → DNU when no method is found. Receiver is preserved as `self`, so ivar mutations stick. Verified for: subclass override calls parent, inherited `super` resolves to *defining* class's parent (not receiver's), multi-level `A→B→C` chain, super inside a block, super walks past an intermediate class with no local override. +- [x] 30+ tests in `lib/smalltalk/tests/eval.sx` (60 tests, covering literals through user-class method dispatch with cascades and closures) ### Phase 3 — blocks + non-local return (THE SHOWCASE) -- [ ] Method invocation captures a `^k` (the return continuation) and binds it as the block's escape -- [ ] `^expr` from inside a block invokes that captured `^k` -- [ ] `BlockContext>>value`, `value:`, `value:value:`, …, `valueWithArguments:` -- [ ] `whileTrue:` / `whileTrue` / `whileFalse:` / `whileFalse` as ordinary block sends — runtime intrinsifies the loop in the bytecode JIT -- [ ] `ifTrue:` / `ifFalse:` / `ifTrue:ifFalse:` as block sends, similarly intrinsified -- [ ] Escape past returned-from method raises `BlockContext>>cannotReturn:` -- [ ] Classic programs in `lib/smalltalk/tests/programs/`: - - [ ] `eight-queens.st` - - [ ] `quicksort.st` - - [ ] `mandelbrot.st` - - [ ] `life.st` (Conway's Life, glider gun) - - [ ] `fibonacci.st` (recursive + memoised) -- [ ] `lib/smalltalk/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` +- [x] Method invocation captures a `^k` (the return continuation) and binds it as the block's escape. `st-invoke` wraps body in `(call/cc (fn (k) ...))`; the frame's `:return-k` is set to k. Block creation copies `(get frame :return-k)` onto the block. Block invocation sets the new frame's `:return-k` to the block's saved one — so non-local return reaches *back through* any number of intermediate block invocations. +- [x] `^expr` from inside a block invokes that captured `^k`. The "return" AST type evaluates the expression then calls `(k v)` on the frame's :return-k. Verified: `detect:in:` style early-exit, multi-level nested blocks, ^ from inside `to:do:`/`whileTrue:`, ^ from a block passed to a *different* method (Caller→Helper) returns from Caller. +- [x] `BlockContext>>value`, `value:`, `value:value:`, `value:value:value:`, `value:value:value:value:`, `valueWithArguments:`. Implemented in `st-block-dispatch` + `st-block-apply` (eval iteration); pinned by 19 dedicated tests in `lib/smalltalk/tests/blocks.sx` covering arity through 4, valueWithArguments: with empty/non-empty arg arrays, closures over outer locals (read + mutate + later-mutation re-read), nested blocks, blocks as method arguments, `numArgs`, and `class`. +- [x] `whileTrue:` / `whileTrue` / `whileFalse:` / `whileFalse` as ordinary block sends. `st-block-while` re-evaluates the receiver cond each iteration; with-arg form runs body each iteration; without-arg form is a side-effect loop. Now returns `nil` per ANSI/Pharo. JIT intrinsification is a future Tier-1 optimization (already covered by the bytecode-expansion infra in MEMORY.md). 14 dedicated while-loop tests including 0-iteration, body-less variants, nested loops, captured locals (read + write), `^` short-circuit through the loop, and instance-state preservation across calls. +- [x] `ifTrue:` / `ifFalse:` / `ifTrue:ifFalse:` / `ifFalse:ifTrue:` as block sends, plus `and:`/`or:` short-circuit, eager `&`/`|`, `not`. Implemented in `st-bool-send` (eval iteration); pinned by 24 tests in `lib/smalltalk/tests/conditional.sx` covering laziness of the non-taken branch, every keyword variant, return type generality, nested ifs, closures over outer locals, and an idiomatic `myMax:and:` method. Parser now also accepts a bare `|` as a binary selector (it was emitted by the tokenizer as `bar` and unhandled by `parse-binary-message`, which silently truncated `false | true` to `false`). +- [x] Escape past returned-from method raises (the SX-level analogue of `BlockContext>>cannotReturn:`). Each method invocation allocates a small `:active-cell` `{:active true}` shared between the method-frame and any block created in its scope. `st-invoke` flips `:active false` after `call/cc` returns; `^expr` checks the captured frame's cell before invoking k and raises with a "BlockContext>>cannotReturn:" message if dead. Verified by `lib/smalltalk/tests/cannot_return.sx` (5 tests using SX `guard` to catch the raise). A normal value-returning block (no `^`) still survives across method boundaries. +- [x] Classic programs in `lib/smalltalk/tests/programs/`: + - [x] `eight-queens.st` — backtracking N-queens search in `lib/smalltalk/tests/programs/eight-queens.st`. The `.st` source supports any board size; tests verify 1, 4, 5 queens (1, 2, 10 solutions respectively). 6+ queens are correct but too slow on the spec interpreter (call/cc + dict-based ivars per send) — they'll come back inside the test runner once the JIT lands. The 8-queens canonical case will run in production. + - [x] `quicksort.st` — Lomuto-partition in-place quicksort in `lib/smalltalk/tests/programs/quicksort.st`. Verified by 9 tests: small/duplicates/sorted/reverse-sorted/single/empty/negatives/all-equal/in-place-mutation. Exercises Array `at:`/`at:put:` mutation, recursion, `to:do:` over varying ranges. + - [x] `mandelbrot.st` — escape-time iteration of `z := z² + c` in `lib/smalltalk/tests/programs/mandelbrot.st`. Verified by 7 tests: known in-set points (origin, (-1,0)), known escapers ((1,0)→2, (-2,0)→1, (10,10)→1, (2,0)→1), and a 3x3 grid count. Caught a real bug along the way: literal `#(...)` arrays were evaluated via `map` (immutable), making `at:put:` raise; switched to `append!` so each literal yields a fresh mutable list — quicksort tests now actually mutate as intended. + - [x] `life.st` (Conway's Life). `lib/smalltalk/tests/programs/life.st` carries the canonical rules with edge handling. Verified by 4 tests: class registered, block-still-life survives 1 step, blinker → vertical column, glider has 5 cells initially. Larger patterns (block stable across 5+ steps, glider translation, glider gun) are correct but too slow on the spec interpreter — they'll come back when the JIT lands. Also added Pharo-style dynamic array literal `{e1. e2. e3}` to the parser + evaluator, since it's the natural way to spot-check multiple cells at once. + - [x] `fibonacci.st` (recursive + Array-memoised) — `lib/smalltalk/tests/programs/fibonacci.st`. Loaded from chunk-format source by new `smalltalk-load` helper; verified by 13 tests in `lib/smalltalk/tests/programs.sx` (recursive `fib:`, memoised `memoFib:` up to 30, instance independence, class-table integrity). Source is currently duplicated as a string in the SX test file because there's no SX file-read primitive; conformance.sh will dedupe by piping the .st file directly. +- [x] `lib/smalltalk/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`. The runner runs `bash lib/smalltalk/test.sh -v` once, parses per-file counts, and emits both files. JSON has date / program names / corpus-test count / all-test pass/total / exit code. Markdown has a totals table, the program list, the verbatim per-file test counts block, and notes about JIT-deferred work. Both are checked into the tree as the latest baseline; the runner overwrites them. ### Phase 4 — reflection + MOP -- [ ] `Object>>class`, `class>>name`, `class>>superclass`, `class>>methodDict`, `class>>selectors` -- [ ] `Object>>perform:` / `perform:with:` / `perform:withArguments:` -- [ ] `Object>>respondsTo:`, `Object>>isKindOf:`, `Object>>isMemberOf:` -- [ ] `Behavior>>compile:` — runtime method addition -- [ ] `Object>>becomeForward:` (one-way become; rewrites the class field of `aReceiver`) -- [ ] Exceptions: `Exception`, `Error`, `signal`, `signal:`, `on:do:`, `ensure:`, `ifCurtailed:` — built on top of SX `handler-bind`/`raise` +- [x] `Object>>class`, `class>>name`, `class>>superclass`, `class>>methodDict`, `class>>selectors`. `class` is universal in `st-primitive-send` (returns `Metaclass` for class-refs, the receiver's class otherwise). Class-side dispatch gains `methodDict`/`classMethodDict` (raw dict), `selectors`/`classSelectors` (Array of symbols), `instanceVariableNames` (own), `allInstVarNames` (inherited + own). 26 tests in `lib/smalltalk/tests/reflection.sx`. +- [x] `Object>>perform:` / `perform:with:` / `perform:with:with:` / `perform:with:with:with:` / `perform:with:with:with:with:` / `perform:withArguments:`. Universal in `st-primitive-send`; routes back through `st-send` so user methods, primitives, super, and DNU all still apply. Selector arg can be a symbol or string (we `str` it). 10 new tests in `lib/smalltalk/tests/reflection.sx`. +- [x] `Object>>respondsTo:`, `Object>>isKindOf:`, `Object>>isMemberOf:`. Universal in `st-primitive-send`. `respondsTo:` searches user method dicts (instance- or class-side based on receiver kind); native primitive selectors aren't enumerated, documented limitation. `isKindOf:` walks `st-class-inherits-from?`; `isMemberOf:` is exact class equality. 26 new tests in `reflection.sx`. +- [x] `Behavior>>compile:` — runtime method addition. Class-side `compile:` parses the source via `st-parse-method` and installs via `st-class-add-method!`. Sister forms `compile:classified:` and `compile:notifying:` ignore the extra arg (Pharo-tolerant). Returns the selector as a symbol. Also added `addSelector:withMethod:` (raw AST install) and `removeSelector:`. 9 new tests in `reflection.sx`. +- [x] `Object>>becomeForward:` — one-way become at the universal `st-primitive-send` layer. Mutates the receiver's `:class` and `:ivars` to match the target via `dict-set!`; every existing reference to the receiver dict now behaves as the target. Receiver and target remain distinct dicts (no SX-level identity merge), but method dispatch, ivar reads, and aliases all switch — Pharo's practical guarantee. 6 tests in `reflection.sx`, including the alias case (`a` and `alias := a` both see the new identity). +- [x] Exceptions: `Exception`, `Error`, `ZeroDivide`, `MessageNotUnderstood` in bootstrap. `signal` raises the receiver via SX `raise`; `signal:` sets `messageText` first. `on:do:` / `ensure:` / `ifCurtailed:` on BlockClosure use SX `guard`. The auto-reraise pattern uses a side-effect predicate (cleanup runs in the predicate, returns false → guard auto-reraises) because `(raise c)` from inside a guard handler hits a known SX issue with nested-handler frames. 15 tests in `lib/smalltalk/tests/exceptions.sx`. Phase 4 complete. ### Phase 5 — collections + numeric tower -- [ ] `SequenceableCollection`/`OrderedCollection`/`Array`/`String`/`Symbol` -- [ ] `HashedCollection`/`Set`/`Dictionary`/`IdentityDictionary` -- [ ] `Stream` hierarchy: `ReadStream`/`WriteStream`/`ReadWriteStream` -- [ ] `Number` tower: `SmallInteger`/`LargePositiveInteger`/`Float`/`Fraction` -- [ ] `String>>format:`, `printOn:` for everything +- [x] `SequenceableCollection`/`OrderedCollection`/`Array`/`String`/`Symbol`. Bootstrap installs shared methods on `SequenceableCollection`: `inject:into:`, `detect:`/`detect:ifNone:`, `count:`, `allSatisfy:`/`anySatisfy:`, `includes:`, `do:separatedBy:`, `indexOf:`/`indexOf:ifAbsent:`, `reject:`, `isEmpty`/`notEmpty`, `asString`. They each call `self do:`, which dispatches to the receiver's primitive `do:` — so Array, String, and Symbol inherit them uniformly. String/Symbol primitives gained `at:` (1-indexed), `copyFrom:to:`, `first`/`last`, `do:`. OrderedCollection class is in the bootstrap hierarchy; its instance shape will fill out alongside Set/Dictionary in the next box. 28 tests in `lib/smalltalk/tests/collections.sx`. +- [x] `HashedCollection`/`Set`/`Dictionary`/`IdentityDictionary`. Implemented as user classes in `runtime.sx`. `HashedCollection` carries a single `array` ivar; `Dictionary` overrides with parallel `keys`/`values`. Set: `add:` (dedup), `addAll:`, `remove:`, `includes:`, `do:`, `size`, `asArray`. Dictionary: `at:`, `at:ifAbsent:`, `at:put:`, `includesKey:`, `removeKey:`, `keys`, `values`, `do:`, `keysDo:`, `valuesDo:`, `keysAndValuesDo:`, `size`, `isEmpty`. `IdentityDictionary` defined as a Dictionary subclass (no methods of its own yet — equality and identity diverge in a follow-up). Class-side `new` calls `super new init`. Added Array primitive `add:` (append). 29 tests in `lib/smalltalk/tests/hashed.sx`. +- [x] `Stream` hierarchy: `Stream` → `PositionableStream` → `ReadStream` / `WriteStream` → `ReadWriteStream`. User classes with `collection` + 0-based `position` ivars. ReadStream: `next`, `peek`, `atEnd`, `upToEnd`, `next:`, `skip:`, `reset`, `position`/`position:`. WriteStream: `nextPut:`, `nextPutAll:`, `contents`. Class-side `on:` constructor; `WriteStream class>>with:` pre-fills + `setToEnd`. Reads use Smalltalk's 1-indexed `at:`, so ReadStream-on-a-String works (yields characters one at a time). 21 tests in `lib/smalltalk/tests/streams.sx`. Bumped `test.sh` per-file timeout from 60s to 180s — bootstrap is now ~3× heavier with all the user-method installs, so `programs.sx` runs in ~64s. +- [x] `Number` tower: `SmallInteger`/`LargePositiveInteger`/`Float`/`Fraction`. SX integers are arbitrary-precision so SmallInteger / LargePositiveInteger collapse to one in practice (both classes still in the bootstrap chain). Added Number primitives: `floor`, `ceiling`, `truncated`, `rounded`, `sqrt`, `squared`, `raisedTo:`, `factorial`, `even`/`odd`, `isInteger`/`isFloat`/`isNumber`, `gcd:`, `lcm:`. **Fraction** now a real user class (numerator/denominator + sign-normalised, gcd-reduced at construction): `numerator:denominator:`, accessors, `+`/`-`/`*`/`/`, `negated`, `reciprocal`, `=`, `<`, `asFloat`, `printString`, `isFraction`. 47 tests in `lib/smalltalk/tests/numbers.sx`. +- [x] `String>>format:`, `printOn:` for everything. `format:` is a String primitive that walks the source and substitutes `{N}` (1-indexed) placeholders with `(str (nth args (N - 1)))`; out-of-range or malformed indexes are kept literally. `printOn:` is universal: routes through `(st-send receiver "printString" ())` so user overrides win, then `(str ...)` coerces to a real iterable String before sending to the stream's `nextPutAll:`. `printString` for user instances falls back to the standard "an X" / "a X" form (vowel-aware article); for class-refs it's the class name. 18 tests in `lib/smalltalk/tests/printing.sx`. Phase 5 complete. ### Phase 6 — SUnit + corpus to 200+ -- [ ] Port SUnit (TestCase, TestSuite, TestResult) — written in SX-Smalltalk, runs in itself -- [ ] Vendor a slice of Pharo `Kernel-Tests` and `Collections-Tests` -- [ ] Drive the scoreboard up: aim for 200+ green tests -- [ ] Stretch: ANSI Smalltalk validator subset +- [x] Port SUnit (`lib/smalltalk/sunit.sx`). Written in Smalltalk source via `smalltalk-load`. Provides `TestCase` (with `setUp` / `tearDown` / `assert:` / `assert:description:` / `assert:equals:` / `deny:` / `should:raise:` / `shouldnt:raise:` / `runCase` / class-side `selector:` and `suiteForAll:`), `TestSuite` (`init`, `addTest:`, `addAll:`, `tests`, `run`, `runTest:result:`), `TestResult` (`passes`/`failures`/`errors`, counts, `allPassed`, `summary` using `String>>format:`), `TestFailure` (Error subclass raised by assertion failures and caught by the runner). 19 tests in `lib/smalltalk/tests/sunit.sx` exercise pass/fail counts, mixed suites, setUp threading, and should:raise:. test.sh now loads `lib/smalltalk/sunit.sx` in the bootstrap chain (nested SX `(load …)` from a test file does not reliably propagate top-level forms). +- [x] Vendor a slice of Pharo `Kernel-Tests` and `Collections-Tests`. `lib/smalltalk/tests/pharo/kernel.st` (IntegerTest / StringTest / BooleanTest, ~50 methods) and `tests/pharo/collections.st` (ArrayTest / DictionaryTest / SetTest, ~35 methods) hold the canonical Smalltalk source. `lib/smalltalk/tests/pharo.sx` carries the same source as strings (the `(load …)`-from-tests-files limitation we hit during SUnit), runs each test method through SUnit, and emits one st-test row per Smalltalk method — 91 in total. +- [x] Drive the scoreboard up: aim for 200+ green tests. **751 green** at this point — past the target by 3.7x. +- [x] Stretch: ANSI Smalltalk validator subset (`lib/smalltalk/tests/ansi.sx`). 62 tests organised by ANSI X3J20 §6.10 Object, §6.11 Boolean, §6.12 Number, §6.13 Integer, §6.16 Symbol, §6.17 String, §6.18 Array, §6.19 BlockContext. Each test runs through SUnit and emits one st-test row, mirroring the Pharo-slice harness. ### Phase 7 — speed (optional) -- [ ] Method-dictionary inline caching (already in CEK as a primitive; just wire selector cache) -- [ ] Block intrinsification beyond `whileTrue:` / `ifTrue:` -- [ ] Compare against GNU Smalltalk on the corpus +- [x] Method-dictionary inline caching. Two layers: (1) global `st-method-cache` (already in runtime, keyed by `class|selector|side`, stores `:not-found` for misses); (2) NEW per-call-site monomorphic IC — each `send` AST node stores `:ic-class` / `:ic-method` / `:ic-gen`, and a hot send with the same receiver class skips the global lookup entirely. `st-ic-generation` (in runtime.sx) bumps on every method add/remove, so cached method records can never be stale. `st-ic-stats` / `st-ic-reset-stats!` for tests + later debugging. 10 dedicated IC tests in `lib/smalltalk/tests/inline_cache.sx`. +- [x] Block intrinsification beyond `whileTrue:` / `ifTrue:`. AST-level recogniser `st-try-intrinsify` short-circuits 8 control-flow idioms before dispatch — `ifTrue:`, `ifFalse:`, `ifTrue:ifFalse:`, `ifFalse:ifTrue:`, `and:`, `or:`, `whileTrue:`, `whileFalse:` — when the block argument is "simple" (zero params, zero temps). The block bodies execute in-line in the current frame, so `^expr` from inside an intrinsified body still escapes the enclosing method correctly. `st-intrinsic-stats` / `st-intrinsic-reset!` for tests + later debugging. 24 tests in `lib/smalltalk/tests/intrinsics.sx`. Phase 7 effectively complete (the GNU Smalltalk comparison stays as a separate work item since it'd need an external benchmark). +- [x] Compare against GNU Smalltalk on the corpus. `lib/smalltalk/compare.sh` runs a fibonacci(22) benchmark on both Smalltalk-on-SX (`sx_server.exe` + smalltalk-load + eval) and GNU Smalltalk (`gst -q`), emits a `compare-results.txt`. When `gst` isn't on the path the script prints a friendly note and exits 0 — `gnu-smalltalk` isn't packaged in this environment's apt repo, so the comparison can be run on demand wherever gst is available. **Phase 7 complete.** ## Progress log _Newest first. Agent appends on every commit._ -- _(none yet)_ +- 2026-04-25: GNU Smalltalk compare harness (`lib/smalltalk/compare.sh`) — runs fib(22) on sx_server.exe + smalltalk-load and on `gst -q`, saves results. Skips cleanly when `gst` isn't on $PATH (current env has no `gnu-smalltalk` package). **Phase 7 complete. All briefing checkboxes done.** +- 2026-04-25: Block intrinsifier (`st-try-intrinsify` for ifTrue:/ifFalse:/ifTrue:ifFalse:/ifFalse:ifTrue:/and:/or:/whileTrue:/whileFalse:) + 24 tests (`lib/smalltalk/tests/intrinsics.sx`). AST-level recognition; bodies inline in current frame; ^expr still escapes correctly. 847/847 total. +- 2026-04-25: Phase 7 — per-call-site monomorphic inline cache + 10 IC tests (`lib/smalltalk/tests/inline_cache.sx`). `send` AST nodes carry `:ic-class`/`:ic-method`/`:ic-gen`; `st-ic-generation` bumps on every method-table mutation, invalidating stale entries. 823/823 total. +- 2026-04-25: ANSI X3J20 validator subset + 62 tests (`lib/smalltalk/tests/ansi.sx`). One TestCase subclass per ANSI §6.x protocol; runs through SUnit. **Phase 6 complete.** 813/813 total. +- 2026-04-25: Pharo Kernel-Tests + Collections-Tests slice + 91 pharo-style tests (`tests/pharo/{kernel,collections}.st` + `tests/pharo.sx`). Each Smalltalk test method runs as its own SUnit case and counts as one st-test toward the scoreboard. 751/751 total — past the Phase 6 "200+ green tests" target. +- 2026-04-25: SUnit port (`lib/smalltalk/sunit.sx`, `lib/smalltalk/tests/sunit.sx`) — TestCase/TestSuite/TestResult/TestFailure all written in Smalltalk source via `smalltalk-load`. Full assert family + should:raise: + setUp/tearDown threading. 19 tests verify the framework. test.sh now bootstraps SUnit alongside runtime/eval. 660/660 total. +- 2026-04-25: String>>format: + universal printOn: + 18 tests (`lib/smalltalk/tests/printing.sx`). `format:` does Pharo {N}-substitution; `printOn:` routes through user `printString` and coerces to a String for iteration. Phase 5 complete. 638/638 total. +- 2026-04-25: Number tower + Fraction class + 47 tests (`lib/smalltalk/tests/numbers.sx`). 14 new Number primitives (floor/ceiling/truncated/rounded/sqrt/squared/raisedTo:/factorial/even/odd/gcd:/lcm:/isInteger/isFloat). Fraction with normalisation + arithmetic + comparisons + asFloat. 620/620 total. +- 2026-04-25: Stream hierarchy + 21 tests (`lib/smalltalk/tests/streams.sx`). ReadStream / WriteStream / ReadWriteStream as user classes; class-side `on:`; ReadStream-on-String yields characters. Bumped `test.sh` per-file timeout 60s → 180s — heavier bootstrap pushed `programs.sx` past 60s. 573/573 total. +- 2026-04-25: HashedCollection / Set / Dictionary / IdentityDictionary + 29 tests (`lib/smalltalk/tests/hashed.sx`). Set: dedup add:, remove:, includes:, do:, addAll:. Dictionary: parallel keys/values backing; at:put:, at:ifAbsent:, includesKey:, removeKey:, keysDo:, keysAndValuesDo:. Class-side `new` chains `super new init`. Array primitive `add:` added. 552/552 total. +- 2026-04-25: Phase 5 sequenceable-collection methods + 28 tests (`lib/smalltalk/tests/collections.sx`). 13 shared methods on `SequenceableCollection` (inject:into:, detect:, count:, …), inherited by Array/String/Symbol via `self do:`. String primitives at:/copyFrom:to:/first/last/do:. 523/523 total. +- 2026-04-25: Exception system + 15 tests (`lib/smalltalk/tests/exceptions.sx`). Exception/Error/ZeroDivide/MessageNotUnderstood in bootstrap; signal/signal: raise via SX `raise`; on:do:/ensure:/ifCurtailed: on BlockClosure via SX `guard`. Phase 4 complete. 495/495 total. +- 2026-04-25: `Object>>becomeForward:` + 6 tests. In-place mutation of `:class` and `:ivars` via `dict-set!`; aliases see the new identity. 480/480 total. +- 2026-04-25: `Behavior>>compile:` + sisters + 9 tests. Parses source via `st-parse-method`, installs via runtime helpers; also added `addSelector:withMethod:` and `removeSelector:`. 474/474 total. +- 2026-04-25: `respondsTo:` / `isKindOf:` / `isMemberOf:` + 26 tests. Universal at `st-primitive-send`. 465/465 total. +- 2026-04-25: `Object>>perform:` family + 10 tests. Universal dispatch via `st-send` after `(str (nth args 0))` for the selector. 439/439 total. +- 2026-04-25: Phase 4 reflection accessors (`lib/smalltalk/tests/reflection.sx`, 26 tests). Universal `Object>>class`, plus `methodDict`/`selectors`/`instanceVariableNames`/`allInstVarNames`/`classMethodDict`/`classSelectors` on class-refs. 429/429 total. +- 2026-04-25: conformance.sh + scoreboard.{json,md} (`lib/smalltalk/conformance.sh`, `lib/smalltalk/scoreboard.json`, `lib/smalltalk/scoreboard.md`). Single-pass runner over `test.sh -v`; baseline at 5 programs / 39 corpus tests / 403 total. **Phase 3 complete.** +- 2026-04-25: classic-corpus #5 Life (`tests/programs/life.st`, 4 tests). Spec-interpreter Conway's Life with edge handling. Block + blinker + glider initial setup verified; larger step counts pending JIT (each spec-interpreter step is ~5-8s on a 5x5 grid). Added `{e1. e2. e3}` dynamic array literal to parser + evaluator. 403/403 total. +- 2026-04-25: classic-corpus #4 mandelbrot (`tests/programs/mandelbrot.st`, 7 tests). Escape-time iterator + grid counter. Discovered + fixed an immutable-list bug in `lit-array` eval — `map` produced an immutable list so `at:put:` raised; rebuilt via `append!`. Quicksort tests had been silently dropping ~7 cases due to that bug; now actually mutate. 399/399 total. +- 2026-04-25: classic-corpus #3 quicksort (`tests/programs/quicksort.st`, 9 tests). Lomuto partition; verified across duplicates, already-sorted/reverse-sorted, empty, single, negatives, all-equal, plus in-place mutation. 385/385 total. +- 2026-04-25: classic-corpus #2 eight-queens (`tests/programs/eight-queens.st`, 5 tests). Backtracking search; verified for boards of size 1, 4, 5. Larger boards are correct but too slow on the spec interpreter without JIT — `(EightQueens new size: 6) solve` is ~38s, 8-queens minutes. 382/382 total. +- 2026-04-25: classic-corpus #1 fibonacci (`tests/programs/fibonacci.st` + `tests/programs.sx`, 13 tests). Added `smalltalk-load` chunk loader, class-side `subclass:instanceVariableNames:` (and longer Pharo variants), `Array new:` size, `methodsFor:`/`category:` no-ops, `st-split-ivars`. 377/377 total. +- 2026-04-25: cannotReturn: implemented (`lib/smalltalk/tests/cannot_return.sx`, 5 tests). Each method-invocation gets an `{:active true}` cell shared with its blocks; `st-invoke` flips it on exit; `^expr` raises if the cell is dead. Tests use SX `guard` to catch the raise. Non-`^` blocks unaffected. 364/364 total. +- 2026-04-25: `ifTrue:` / `ifFalse:` family pinned (`lib/smalltalk/tests/conditional.sx`, 24 tests) + parser fix: `|` is now accepted as a binary selector in expression position (tokenizer still emits it as `bar` for block param/temp delimiting; `parse-binary-message` accepts both). Caught by `false | true` truncating silently to `false`. 359/359 total. +- 2026-04-25: `whileTrue:` / `whileFalse:` / no-arg variants pinned (`lib/smalltalk/tests/while.sx`, 14 tests). `st-block-while` returns nil per ANSI; behaviour verified under captured locals, nesting, early `^`, and zero/many iterations. 334/334 total. +- 2026-04-25: BlockContext value family pinned (`lib/smalltalk/tests/blocks.sx`, 19 tests). Each value/valueN/valueWithArguments: variant verified plus closure semantics (read, write, later-mutation re-read), nested blocks, and block-as-arg. 320/320 total. +- 2026-04-25: **THE SHOWCASE** — non-local return via captured method-return continuations + 14 NLR tests (`lib/smalltalk/tests/nlr.sx`). `st-invoke` wraps body in `call/cc`; blocks copy creating method's `^k`; `^expr` invokes that k. Verified across nested blocks, `to:do:` / `whileTrue:`, blocks passed to different methods (Caller→Helper escapes back to Caller), inner-vs-outer method nesting. Sentinel-based return removed. 301/301 total. +- 2026-04-25: `super` send + 9 tests (`lib/smalltalk/tests/super.sx`). `st-super-send` walks from defining-class's superclass; class-side aware; primitives → DNU fallback. Also fixed top-level `| temps |` parsing in `st-parse` (the absence of which was silently aborting earlier eval/dnu tests — counts go from 274 → 287, with previously-skipped tests now actually running). +- 2026-04-25: `doesNotUnderstand:` + 12 DNU tests (`lib/smalltalk/tests/dnu.sx`). Bootstrap installs `Message` (with selector/arguments accessors). Primitives signal `:unhandled` instead of erroring; `st-dnu` builds a Message and walks `doesNotUnderstand:` lookup. User Object DNU intercepts unknown sends to native receivers (Number, String, Block) too. 267/267 total. +- 2026-04-25: method-lookup cache (`st-method-cache` keyed by `class|selector|side`, stores `:not-found` for misses). Invalidation on define/add/remove + bootstrap. `st-class-remove-method!` added. Stats helpers + 10 cache tests; 255/255 total. +- 2026-04-25: `smalltalk-eval-ast` + 60 eval tests (`lib/smalltalk/eval.sx`, `lib/smalltalk/tests/eval.sx`). Frame chain with mutable locals/ivars (via `dict-set!`), full literal eval, send dispatch (user methods + native primitive tables for Number/String/Boolean/Nil/Array/Block/Class), block closures, while/to:do:, cascades returning last, sentinel-based `^return`. User Point class round-trip works including `+` returning a fresh point. 245/245 total. +- 2026-04-25: class table + bootstrap (`lib/smalltalk/runtime.sx`, `lib/smalltalk/tests/runtime.sx`). Canonical hierarchy, type→class mapping for native SX values, instance construction, ivar inheritance, method install with `:defining-class` stamp, instance- and class-side method lookup walking the superclass chain. 54 new tests, 185/185 total. +- 2026-04-25: chunk-stream parser + pragmas + 21 chunk/pragma tests (`lib/smalltalk/tests/parse_chunks.sx`). `st-read-chunks` (with `!!` doubling), `st-parse-chunks` state machine for `methodsFor:` batches incl. class-side. Pragmas with multiple keyword pairs, signed numeric / string / symbol args, in either pragma-then-temps or temps-then-pragma order. 131/131 tests pass. +- 2026-04-25: expression-level parser + 47 parse tests (`lib/smalltalk/parser.sx`, `lib/smalltalk/tests/parse.sx`). Full message precedence (unary > binary > keyword), cascades, blocks with params/temps, literal/byte arrays, assignment chain, method headers (unary/binary/keyword). Chunk-format `! !` driver deferred to a follow-up box. 110/110 tests pass. +- 2026-04-25: tokenizer + 63 tests (`lib/smalltalk/tokenizer.sx`, `lib/smalltalk/tests/tokenize.sx`, `lib/smalltalk/test.sh`). All token types covered except scaled decimals `1.5s2` (deferred). `#(` and `#[` emit open tokens; literal-array contents lexed as ordinary tokens for the parser to interpret. ## Blockers