Compare commits
7 Commits
loops/smal
...
loops/tcl
| Author | SHA1 | Date | |
|---|---|---|---|
| 35aa998fcc | |||
| 6ee052593c | |||
| 1a17d8d232 | |||
| 666e29d5f0 | |||
| 3316d402fd | |||
| fb72c4ab9c | |||
| e52c209c3d |
@@ -1,90 +0,0 @@
|
||||
#!/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" <<EOF
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(load "lib/smalltalk/parser.sx")
|
||||
(load "lib/smalltalk/runtime.sx")
|
||||
(load "lib/smalltalk/eval.sx")
|
||||
(epoch 2)
|
||||
(eval "(begin (st-bootstrap-classes!) (smalltalk-load \"Object subclass: #B instanceVariableNames: ''! !B methodsFor: 'x'! fib: n n < 2 ifTrue: [^ n]. ^ (self fib: n - 1) + (self fib: n - 2)! !\") (smalltalk-eval-program \"^ B new fib: 22\"))")
|
||||
EOF
|
||||
local start=$(date +%s.%N)
|
||||
timeout 60 "$SX" < "$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" <<EOF
|
||||
| start delta b |
|
||||
b := Object subclass: #B
|
||||
instanceVariableNames: ''
|
||||
classVariableNames: ''
|
||||
package: 'demo'.
|
||||
b compile: 'fib: n n < 2 ifTrue: [^ n]. ^ (self fib: n - 1) + (self fib: n - 2)'.
|
||||
start := Time millisecondClock.
|
||||
B new fib: 22.
|
||||
delta := Time millisecondClock - start.
|
||||
Transcript show: 'gst ', delta printString, 'ms'; nl.
|
||||
EOF
|
||||
local start=$(date +%s.%N)
|
||||
timeout 60 gst -q "$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"
|
||||
@@ -1,99 +0,0 @@
|
||||
#!/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 <path> 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
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,948 +0,0 @@
|
||||
;; 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: <binary> (kw <binary>)+
|
||||
(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: <unary> (binop <unary>)*
|
||||
;; 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: <primary> 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: `<keyword: literal (keyword: literal)* >`
|
||||
;; 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")}))))))))
|
||||
@@ -1,787 +0,0 @@
|
||||
;; Smalltalk runtime — class table, bootstrap hierarchy, type→class mapping,
|
||||
;; instance construction. Method dispatch / eval-ast live in a later layer.
|
||||
;;
|
||||
;; Class record shape:
|
||||
;; {:name "Foo"
|
||||
;; :superclass "Object" ; or nil for Object itself
|
||||
;; :ivars (list "x" "y") ; instance variable names declared on this class
|
||||
;; :methods (dict selector→method-record)
|
||||
;; :class-methods (dict selector→method-record)}
|
||||
;;
|
||||
;; A method record is the AST returned by st-parse-method, plus a :defining-class
|
||||
;; field so super-sends can resolve from the right place. (Methods are registered
|
||||
;; via runtime helpers that fill the field.)
|
||||
;;
|
||||
;; The class table is a single dict keyed by class name. Bootstrap installs the
|
||||
;; canonical hierarchy. Test code resets it via (st-bootstrap-classes!).
|
||||
|
||||
(define st-class-table {})
|
||||
|
||||
;; ── Method-lookup cache ────────────────────────────────────────────────
|
||||
;; Cache keys are "class|selector|side"; side is "i" (instance) or "c" (class).
|
||||
;; Misses are stored as the sentinel :not-found so we don't re-walk for
|
||||
;; every doesNotUnderstand call.
|
||||
(define st-method-cache {})
|
||||
(define st-method-cache-hits 0)
|
||||
(define st-method-cache-misses 0)
|
||||
|
||||
(define
|
||||
st-method-cache-clear!
|
||||
(fn () (set! st-method-cache {})))
|
||||
|
||||
;; Inline-cache generation. Eval-time IC slots check this; bumping it
|
||||
;; invalidates every cached call-site method record across the program.
|
||||
(define st-ic-generation 0)
|
||||
|
||||
(define
|
||||
st-ic-bump-generation!
|
||||
(fn () (set! st-ic-generation (+ st-ic-generation 1))))
|
||||
|
||||
(define
|
||||
st-method-cache-key
|
||||
(fn (cls sel class-side?) (str cls "|" sel "|" (if class-side? "c" "i"))))
|
||||
|
||||
(define
|
||||
st-method-cache-stats
|
||||
(fn
|
||||
()
|
||||
{:hits st-method-cache-hits
|
||||
:misses st-method-cache-misses
|
||||
:size (len (keys st-method-cache))}))
|
||||
|
||||
(define
|
||||
st-method-cache-reset-stats!
|
||||
(fn ()
|
||||
(begin
|
||||
(set! st-method-cache-hits 0)
|
||||
(set! st-method-cache-misses 0))))
|
||||
|
||||
(define
|
||||
st-class-table-clear!
|
||||
(fn ()
|
||||
(begin
|
||||
(set! st-class-table {})
|
||||
(st-method-cache-clear!))))
|
||||
|
||||
(define
|
||||
st-class-define!
|
||||
(fn
|
||||
(name superclass ivars)
|
||||
(begin
|
||||
(set!
|
||||
st-class-table
|
||||
(assoc
|
||||
st-class-table
|
||||
name
|
||||
{:name name
|
||||
:superclass superclass
|
||||
:ivars ivars
|
||||
:methods {}
|
||||
:class-methods {}}))
|
||||
;; A redefined class can invalidate any cache entries that walked
|
||||
;; through its old position in the chain. Cheap + correct: drop all.
|
||||
(st-method-cache-clear!)
|
||||
name)))
|
||||
|
||||
(define
|
||||
st-class-get
|
||||
(fn (name) (if (has-key? st-class-table name) (get st-class-table name) nil)))
|
||||
|
||||
(define
|
||||
st-class-exists?
|
||||
(fn (name) (has-key? st-class-table name)))
|
||||
|
||||
(define
|
||||
st-class-superclass
|
||||
(fn
|
||||
(name)
|
||||
(let
|
||||
((c (st-class-get name)))
|
||||
(cond ((= c nil) nil) (else (get c :superclass))))))
|
||||
|
||||
;; Walk class chain root-to-leaf? No, follow superclass chain leaf-to-root.
|
||||
;; Returns list of class names starting at `name` and ending with the root.
|
||||
(define
|
||||
st-class-chain
|
||||
(fn
|
||||
(name)
|
||||
(let ((acc (list)) (cur name))
|
||||
(begin
|
||||
(define
|
||||
ch-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not (= cur nil)) (st-class-exists? cur))
|
||||
(begin
|
||||
(append! acc cur)
|
||||
(set! cur (st-class-superclass cur))
|
||||
(ch-loop)))))
|
||||
(ch-loop)
|
||||
acc))))
|
||||
|
||||
;; Inherited + own ivars in declaration order from root to leaf.
|
||||
(define
|
||||
st-class-all-ivars
|
||||
(fn
|
||||
(name)
|
||||
(let ((chain (reverse (st-class-chain name))) (out (list)))
|
||||
(begin
|
||||
(for-each
|
||||
(fn
|
||||
(cn)
|
||||
(let
|
||||
((c (st-class-get cn)))
|
||||
(when
|
||||
(not (= c nil))
|
||||
(for-each (fn (iv) (append! out iv)) (get c :ivars)))))
|
||||
chain)
|
||||
out))))
|
||||
|
||||
;; Method install. The defining-class field is stamped on the method record
|
||||
;; so super-sends look up from the right point in the chain.
|
||||
(define
|
||||
st-class-add-method!
|
||||
(fn
|
||||
(cls-name selector method-ast)
|
||||
(let
|
||||
((cls (st-class-get cls-name)))
|
||||
(cond
|
||||
((= cls nil) (error (str "st-class-add-method!: unknown class " cls-name)))
|
||||
(else
|
||||
(let
|
||||
((m (assoc method-ast :defining-class cls-name)))
|
||||
(begin
|
||||
(set!
|
||||
st-class-table
|
||||
(assoc
|
||||
st-class-table
|
||||
cls-name
|
||||
(assoc
|
||||
cls
|
||||
:methods
|
||||
(assoc (get cls :methods) selector m))))
|
||||
(st-method-cache-clear!)
|
||||
(st-ic-bump-generation!)
|
||||
selector)))))))
|
||||
|
||||
(define
|
||||
st-class-add-class-method!
|
||||
(fn
|
||||
(cls-name selector method-ast)
|
||||
(let
|
||||
((cls (st-class-get cls-name)))
|
||||
(cond
|
||||
((= cls nil) (error (str "st-class-add-class-method!: unknown class " cls-name)))
|
||||
(else
|
||||
(let
|
||||
((m (assoc method-ast :defining-class cls-name)))
|
||||
(begin
|
||||
(set!
|
||||
st-class-table
|
||||
(assoc
|
||||
st-class-table
|
||||
cls-name
|
||||
(assoc
|
||||
cls
|
||||
:class-methods
|
||||
(assoc (get cls :class-methods) selector m))))
|
||||
(st-method-cache-clear!)
|
||||
(st-ic-bump-generation!)
|
||||
selector)))))))
|
||||
|
||||
;; Remove a method from a class (instance side). Mostly for tests; runtime
|
||||
;; reflection in Phase 4 will use the same primitive.
|
||||
(define
|
||||
st-class-remove-method!
|
||||
(fn
|
||||
(cls-name selector)
|
||||
(let ((cls (st-class-get cls-name)))
|
||||
(cond
|
||||
((= cls nil) (error (str "st-class-remove-method!: unknown class " cls-name)))
|
||||
(else
|
||||
(let ((md (get cls :methods)))
|
||||
(cond
|
||||
((not (has-key? md selector)) false)
|
||||
(else
|
||||
(let ((new-md {}))
|
||||
(begin
|
||||
(for-each
|
||||
(fn (k)
|
||||
(when (not (= k selector))
|
||||
(dict-set! new-md k (get md k))))
|
||||
(keys md))
|
||||
(set!
|
||||
st-class-table
|
||||
(assoc
|
||||
st-class-table
|
||||
cls-name
|
||||
(assoc cls :methods new-md)))
|
||||
(st-method-cache-clear!)
|
||||
(st-ic-bump-generation!)
|
||||
true))))))))))
|
||||
|
||||
;; Walk-only lookup. Returns the method record (with :defining-class) or nil.
|
||||
;; class-side? = true searches :class-methods, false searches :methods.
|
||||
(define
|
||||
st-method-lookup-walk
|
||||
(fn
|
||||
(cls-name selector class-side?)
|
||||
(let
|
||||
((found nil))
|
||||
(begin
|
||||
(define
|
||||
ml-loop
|
||||
(fn
|
||||
(cur)
|
||||
(when
|
||||
(and (= found nil) (not (= cur nil)) (st-class-exists? cur))
|
||||
(let
|
||||
((c (st-class-get cur)))
|
||||
(let
|
||||
((dict (if class-side? (get c :class-methods) (get c :methods))))
|
||||
(cond
|
||||
((has-key? dict selector) (set! found (get dict selector)))
|
||||
(else (ml-loop (get c :superclass)))))))))
|
||||
(ml-loop cls-name)
|
||||
found))))
|
||||
|
||||
;; Cached lookup. Misses are stored as :not-found so doesNotUnderstand paths
|
||||
;; don't re-walk on every send.
|
||||
(define
|
||||
st-method-lookup
|
||||
(fn
|
||||
(cls-name selector class-side?)
|
||||
(let ((key (st-method-cache-key cls-name selector class-side?)))
|
||||
(cond
|
||||
((has-key? st-method-cache key)
|
||||
(begin
|
||||
(set! st-method-cache-hits (+ st-method-cache-hits 1))
|
||||
(let ((v (get st-method-cache key)))
|
||||
(cond ((= v :not-found) nil) (else v)))))
|
||||
(else
|
||||
(begin
|
||||
(set! st-method-cache-misses (+ st-method-cache-misses 1))
|
||||
(let ((found (st-method-lookup-walk cls-name selector class-side?)))
|
||||
(begin
|
||||
(set!
|
||||
st-method-cache
|
||||
(assoc
|
||||
st-method-cache
|
||||
key
|
||||
(cond ((= found nil) :not-found) (else found))))
|
||||
found))))))))
|
||||
|
||||
;; SX value → Smalltalk class name. Native types are not boxed.
|
||||
(define
|
||||
st-class-of
|
||||
(fn
|
||||
(v)
|
||||
(cond
|
||||
((= v nil) "UndefinedObject")
|
||||
((= v true) "True")
|
||||
((= v false) "False")
|
||||
((integer? v) "SmallInteger")
|
||||
((number? v) "Float")
|
||||
((string? v) "String")
|
||||
((symbol? v) "Symbol")
|
||||
((list? v) "Array")
|
||||
((and (dict? v) (has-key? v :type) (= (get v :type) "st-instance"))
|
||||
(get v :class))
|
||||
((and (dict? v) (has-key? v :type) (= (get v :type) "block"))
|
||||
"BlockClosure")
|
||||
((and (dict? v) (has-key? v :st-block?) (get v :st-block?))
|
||||
"BlockClosure")
|
||||
((dict? v) "Dictionary")
|
||||
((lambda? v) "BlockClosure")
|
||||
(else "Object"))))
|
||||
|
||||
;; Construct a fresh instance of cls-name. Ivars (own + inherited) start as nil.
|
||||
(define
|
||||
st-make-instance
|
||||
(fn
|
||||
(cls-name)
|
||||
(cond
|
||||
((not (st-class-exists? cls-name))
|
||||
(error (str "st-make-instance: unknown class " cls-name)))
|
||||
(else
|
||||
(let
|
||||
((iv-names (st-class-all-ivars cls-name)) (ivars {}))
|
||||
(begin
|
||||
(for-each (fn (n) (set! ivars (assoc ivars n nil))) iv-names)
|
||||
{:type "st-instance" :class cls-name :ivars ivars}))))))
|
||||
|
||||
(define
|
||||
st-instance?
|
||||
(fn
|
||||
(v)
|
||||
(and (dict? v) (has-key? v :type) (= (get v :type) "st-instance"))))
|
||||
|
||||
(define
|
||||
st-iv-get
|
||||
(fn
|
||||
(inst name)
|
||||
(let ((ivs (get inst :ivars)))
|
||||
(if (has-key? ivs name) (get ivs name) nil))))
|
||||
|
||||
(define
|
||||
st-iv-set!
|
||||
(fn
|
||||
(inst name value)
|
||||
(let
|
||||
((new-ivars (assoc (get inst :ivars) name value)))
|
||||
(assoc inst :ivars new-ivars))))
|
||||
|
||||
;; Inherits-from check: is `descendant` either equal to `ancestor` or a subclass?
|
||||
(define
|
||||
st-class-inherits-from?
|
||||
(fn
|
||||
(descendant ancestor)
|
||||
(let ((found false) (cur descendant))
|
||||
(begin
|
||||
(define
|
||||
ih-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not found) (not (= cur nil)) (st-class-exists? cur))
|
||||
(cond
|
||||
((= cur ancestor) (set! found true))
|
||||
(else
|
||||
(begin
|
||||
(set! cur (st-class-superclass cur))
|
||||
(ih-loop)))))))
|
||||
(ih-loop)
|
||||
found))))
|
||||
|
||||
;; Bootstrap the canonical class hierarchy. Reset and rebuild.
|
||||
(define
|
||||
st-bootstrap-classes!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(st-class-table-clear!)
|
||||
;; Root
|
||||
(st-class-define! "Object" nil (list))
|
||||
;; Class side machinery
|
||||
(st-class-define! "Behavior" "Object" (list "superclass" "methodDict" "format"))
|
||||
(st-class-define! "ClassDescription" "Behavior" (list "instanceVariables" "organization"))
|
||||
(st-class-define! "Class" "ClassDescription" (list "name" "subclasses"))
|
||||
(st-class-define! "Metaclass" "ClassDescription" (list "thisClass"))
|
||||
;; Pseudo-variable types
|
||||
(st-class-define! "UndefinedObject" "Object" (list))
|
||||
(st-class-define! "Boolean" "Object" (list))
|
||||
(st-class-define! "True" "Boolean" (list))
|
||||
(st-class-define! "False" "Boolean" (list))
|
||||
;; Magnitudes
|
||||
(st-class-define! "Magnitude" "Object" (list))
|
||||
(st-class-define! "Number" "Magnitude" (list))
|
||||
(st-class-define! "Integer" "Number" (list))
|
||||
(st-class-define! "SmallInteger" "Integer" (list))
|
||||
(st-class-define! "LargePositiveInteger" "Integer" (list))
|
||||
(st-class-define! "Float" "Number" (list))
|
||||
(st-class-define! "Fraction" "Number" (list "numerator" "denominator"))
|
||||
(st-class-define! "Character" "Magnitude" (list "value"))
|
||||
;; Collections
|
||||
(st-class-define! "Collection" "Object" (list))
|
||||
(st-class-define! "SequenceableCollection" "Collection" (list))
|
||||
(st-class-define! "ArrayedCollection" "SequenceableCollection" (list))
|
||||
(st-class-define! "Array" "ArrayedCollection" (list))
|
||||
(st-class-define! "String" "ArrayedCollection" (list))
|
||||
(st-class-define! "Symbol" "String" (list))
|
||||
(st-class-define! "OrderedCollection" "SequenceableCollection" (list "array" "firstIndex" "lastIndex"))
|
||||
;; Hashed collection family
|
||||
(st-class-define! "HashedCollection" "Collection" (list "array"))
|
||||
(st-class-define! "Set" "HashedCollection" (list))
|
||||
;; Blocks / contexts
|
||||
(st-class-define! "BlockClosure" "Object" (list))
|
||||
;; Reflection support — Message holds the selector/args for a DNU send.
|
||||
(st-class-define! "Message" "Object" (list "selector" "arguments"))
|
||||
(st-class-add-method! "Message" "selector"
|
||||
(st-parse-method "selector ^ selector"))
|
||||
(st-class-add-method! "Message" "arguments"
|
||||
(st-parse-method "arguments ^ arguments"))
|
||||
(st-class-add-method! "Message" "selector:"
|
||||
(st-parse-method "selector: aSym selector := aSym"))
|
||||
(st-class-add-method! "Message" "arguments:"
|
||||
(st-parse-method "arguments: anArray arguments := anArray"))
|
||||
;; Exception hierarchy — Smalltalk's standard error system on top of
|
||||
;; SX's `guard`/`raise`. Subclassing Exception gives you on:do:,
|
||||
;; ensure:, ifCurtailed: catching out of the box.
|
||||
(st-class-define! "Exception" "Object" (list "messageText"))
|
||||
(st-class-add-method! "Exception" "messageText"
|
||||
(st-parse-method "messageText ^ messageText"))
|
||||
(st-class-add-method! "Exception" "messageText:"
|
||||
(st-parse-method "messageText: aString messageText := aString. ^ self"))
|
||||
(st-class-define! "Error" "Exception" (list))
|
||||
(st-class-define! "ZeroDivide" "Error" (list))
|
||||
(st-class-define! "MessageNotUnderstood" "Error" (list))
|
||||
;; SequenceableCollection — shared iteration / inspection methods.
|
||||
;; Defined on the parent class so Array, String, Symbol, and
|
||||
;; OrderedCollection all inherit. Each method calls `self do:`,
|
||||
;; which dispatches to the receiver's primitive do: implementation.
|
||||
(st-class-add-method! "SequenceableCollection" "inject:into:"
|
||||
(st-parse-method
|
||||
"inject: initial into: aBlock
|
||||
| acc |
|
||||
acc := initial.
|
||||
self do: [:e | acc := aBlock value: acc value: e].
|
||||
^ acc"))
|
||||
(st-class-add-method! "SequenceableCollection" "detect:"
|
||||
(st-parse-method
|
||||
"detect: aBlock
|
||||
self do: [:e | (aBlock value: e) ifTrue: [^ e]].
|
||||
^ nil"))
|
||||
(st-class-add-method! "SequenceableCollection" "detect:ifNone:"
|
||||
(st-parse-method
|
||||
"detect: aBlock ifNone: noneBlock
|
||||
self do: [:e | (aBlock value: e) ifTrue: [^ e]].
|
||||
^ noneBlock value"))
|
||||
(st-class-add-method! "SequenceableCollection" "count:"
|
||||
(st-parse-method
|
||||
"count: aBlock
|
||||
| n |
|
||||
n := 0.
|
||||
self do: [:e | (aBlock value: e) ifTrue: [n := n + 1]].
|
||||
^ n"))
|
||||
(st-class-add-method! "SequenceableCollection" "allSatisfy:"
|
||||
(st-parse-method
|
||||
"allSatisfy: aBlock
|
||||
self do: [:e | (aBlock value: e) ifFalse: [^ false]].
|
||||
^ true"))
|
||||
(st-class-add-method! "SequenceableCollection" "anySatisfy:"
|
||||
(st-parse-method
|
||||
"anySatisfy: aBlock
|
||||
self do: [:e | (aBlock value: e) ifTrue: [^ true]].
|
||||
^ false"))
|
||||
(st-class-add-method! "SequenceableCollection" "includes:"
|
||||
(st-parse-method
|
||||
"includes: target
|
||||
self do: [:e | e = target ifTrue: [^ true]].
|
||||
^ false"))
|
||||
(st-class-add-method! "SequenceableCollection" "do:separatedBy:"
|
||||
(st-parse-method
|
||||
"do: aBlock separatedBy: sepBlock
|
||||
| first |
|
||||
first := true.
|
||||
self do: [:e |
|
||||
first ifFalse: [sepBlock value].
|
||||
first := false.
|
||||
aBlock value: e].
|
||||
^ self"))
|
||||
(st-class-add-method! "SequenceableCollection" "indexOf:"
|
||||
(st-parse-method
|
||||
"indexOf: target
|
||||
| idx |
|
||||
idx := 1.
|
||||
self do: [:e | e = target ifTrue: [^ idx]. idx := idx + 1].
|
||||
^ 0"))
|
||||
(st-class-add-method! "SequenceableCollection" "indexOf:ifAbsent:"
|
||||
(st-parse-method
|
||||
"indexOf: target ifAbsent: noneBlock
|
||||
| idx |
|
||||
idx := 1.
|
||||
self do: [:e | e = target ifTrue: [^ idx]. idx := idx + 1].
|
||||
^ noneBlock value"))
|
||||
(st-class-add-method! "SequenceableCollection" "reject:"
|
||||
(st-parse-method
|
||||
"reject: aBlock ^ self select: [:e | (aBlock value: e) not]"))
|
||||
(st-class-add-method! "SequenceableCollection" "isEmpty"
|
||||
(st-parse-method "isEmpty ^ self size = 0"))
|
||||
(st-class-add-method! "SequenceableCollection" "notEmpty"
|
||||
(st-parse-method "notEmpty ^ self size > 0"))
|
||||
;; (no asString here — Symbol/String have their own primitive
|
||||
;; impls; SequenceableCollection-level fallback would overwrite
|
||||
;; the bare-name-for-Symbol behaviour.)
|
||||
;; Array class-side constructors for small fixed-arity literals.
|
||||
(st-class-add-class-method! "Array" "with:"
|
||||
(st-parse-method
|
||||
"with: x | a | a := Array new: 1. a at: 1 put: x. ^ a"))
|
||||
(st-class-add-class-method! "Array" "with:with:"
|
||||
(st-parse-method
|
||||
"with: a with: b
|
||||
| r | r := Array new: 2.
|
||||
r at: 1 put: a. r at: 2 put: b. ^ r"))
|
||||
(st-class-add-class-method! "Array" "with:with:with:"
|
||||
(st-parse-method
|
||||
"with: a with: b with: c
|
||||
| r | r := Array new: 3.
|
||||
r at: 1 put: a. r at: 2 put: b. r at: 3 put: c. ^ r"))
|
||||
(st-class-add-class-method! "Array" "with:with:with:with:"
|
||||
(st-parse-method
|
||||
"with: a with: b with: c with: d
|
||||
| r | r := Array new: 4.
|
||||
r at: 1 put: a. r at: 2 put: b. r at: 3 put: c. r at: 4 put: d. ^ r"))
|
||||
;; ── HashedCollection / Set / Dictionary ──
|
||||
;; Implemented as user instances with array-backed storage. Sets
|
||||
;; use a single `array` ivar; Dictionaries use parallel `keys`/
|
||||
;; `values` arrays. New is class-side and routes through `init`.
|
||||
(st-class-add-method! "HashedCollection" "init"
|
||||
(st-parse-method "init array := Array new: 0. ^ self"))
|
||||
(st-class-add-method! "HashedCollection" "size"
|
||||
(st-parse-method "size ^ array size"))
|
||||
(st-class-add-method! "HashedCollection" "isEmpty"
|
||||
(st-parse-method "isEmpty ^ array isEmpty"))
|
||||
(st-class-add-method! "HashedCollection" "notEmpty"
|
||||
(st-parse-method "notEmpty ^ array notEmpty"))
|
||||
(st-class-add-method! "HashedCollection" "do:"
|
||||
(st-parse-method "do: aBlock array do: aBlock. ^ self"))
|
||||
(st-class-add-method! "HashedCollection" "asArray"
|
||||
(st-parse-method "asArray ^ array"))
|
||||
(st-class-add-class-method! "Set" "new"
|
||||
(st-parse-method "new ^ super new init"))
|
||||
(st-class-add-method! "Set" "add:"
|
||||
(st-parse-method
|
||||
"add: anObject
|
||||
(self includes: anObject) ifFalse: [array add: anObject].
|
||||
^ anObject"))
|
||||
(st-class-add-method! "Set" "addAll:"
|
||||
(st-parse-method
|
||||
"addAll: aCollection
|
||||
aCollection do: [:e | self add: e].
|
||||
^ aCollection"))
|
||||
(st-class-add-method! "Set" "remove:"
|
||||
(st-parse-method
|
||||
"remove: anObject
|
||||
array := array reject: [:e | e = anObject].
|
||||
^ anObject"))
|
||||
(st-class-add-method! "Set" "includes:"
|
||||
(st-parse-method "includes: anObject ^ array includes: anObject"))
|
||||
(st-class-define! "Dictionary" "HashedCollection" (list "keys" "values"))
|
||||
(st-class-add-class-method! "Dictionary" "new"
|
||||
(st-parse-method "new ^ super new init"))
|
||||
(st-class-add-method! "Dictionary" "init"
|
||||
(st-parse-method
|
||||
"init keys := Array new: 0. values := Array new: 0. ^ self"))
|
||||
(st-class-add-method! "Dictionary" "size"
|
||||
(st-parse-method "size ^ keys size"))
|
||||
(st-class-add-method! "Dictionary" "isEmpty"
|
||||
(st-parse-method "isEmpty ^ keys isEmpty"))
|
||||
(st-class-add-method! "Dictionary" "notEmpty"
|
||||
(st-parse-method "notEmpty ^ keys notEmpty"))
|
||||
(st-class-add-method! "Dictionary" "keys"
|
||||
(st-parse-method "keys ^ keys"))
|
||||
(st-class-add-method! "Dictionary" "values"
|
||||
(st-parse-method "values ^ values"))
|
||||
(st-class-add-method! "Dictionary" "at:"
|
||||
(st-parse-method
|
||||
"at: aKey
|
||||
| i |
|
||||
i := keys indexOf: aKey.
|
||||
i = 0 ifTrue: [^ nil].
|
||||
^ values at: i"))
|
||||
(st-class-add-method! "Dictionary" "at:ifAbsent:"
|
||||
(st-parse-method
|
||||
"at: aKey ifAbsent: aBlock
|
||||
| i |
|
||||
i := keys indexOf: aKey.
|
||||
i = 0 ifTrue: [^ aBlock value].
|
||||
^ values at: i"))
|
||||
(st-class-add-method! "Dictionary" "at:put:"
|
||||
(st-parse-method
|
||||
"at: aKey put: aValue
|
||||
| i |
|
||||
i := keys indexOf: aKey.
|
||||
i = 0
|
||||
ifTrue: [keys add: aKey. values add: aValue]
|
||||
ifFalse: [values at: i put: aValue].
|
||||
^ aValue"))
|
||||
(st-class-add-method! "Dictionary" "includesKey:"
|
||||
(st-parse-method "includesKey: aKey ^ (keys indexOf: aKey) > 0"))
|
||||
(st-class-add-method! "Dictionary" "removeKey:"
|
||||
(st-parse-method
|
||||
"removeKey: aKey
|
||||
| i nk nv j |
|
||||
i := keys indexOf: aKey.
|
||||
i = 0 ifTrue: [^ nil].
|
||||
nk := Array new: 0. nv := Array new: 0.
|
||||
j := 1.
|
||||
[j <= keys size] whileTrue: [
|
||||
j = i ifFalse: [
|
||||
nk add: (keys at: j).
|
||||
nv add: (values at: j)].
|
||||
j := j + 1].
|
||||
keys := nk. values := nv.
|
||||
^ aKey"))
|
||||
(st-class-add-method! "Dictionary" "do:"
|
||||
(st-parse-method "do: aBlock values do: aBlock. ^ self"))
|
||||
(st-class-add-method! "Dictionary" "keysDo:"
|
||||
(st-parse-method "keysDo: aBlock keys do: aBlock. ^ self"))
|
||||
(st-class-add-method! "Dictionary" "valuesDo:"
|
||||
(st-parse-method "valuesDo: aBlock values do: aBlock. ^ self"))
|
||||
(st-class-add-method! "Dictionary" "keysAndValuesDo:"
|
||||
(st-parse-method
|
||||
"keysAndValuesDo: aBlock
|
||||
| i |
|
||||
i := 1.
|
||||
[i <= keys size] whileTrue: [
|
||||
aBlock value: (keys at: i) value: (values at: i).
|
||||
i := i + 1].
|
||||
^ self"))
|
||||
(st-class-define! "IdentityDictionary" "Dictionary" (list))
|
||||
;; ── Stream hierarchy ──
|
||||
;; Streams wrap a collection with a 0-based `position`. Read/peek
|
||||
;; advance via `at:` (1-indexed Smalltalk-style) on the collection.
|
||||
;; Write streams require a mutable collection (Array works; String
|
||||
;; doesn't, see Phase 5 follow-up).
|
||||
(st-class-define! "Stream" "Object" (list))
|
||||
(st-class-define! "PositionableStream" "Stream" (list "collection" "position"))
|
||||
(st-class-define! "ReadStream" "PositionableStream" (list))
|
||||
(st-class-define! "WriteStream" "PositionableStream" (list))
|
||||
(st-class-define! "ReadWriteStream" "WriteStream" (list))
|
||||
(st-class-add-class-method! "ReadStream" "on:"
|
||||
(st-parse-method "on: aColl ^ super new on: aColl"))
|
||||
(st-class-add-class-method! "WriteStream" "on:"
|
||||
(st-parse-method "on: aColl ^ super new on: aColl"))
|
||||
(st-class-add-class-method! "WriteStream" "with:"
|
||||
(st-parse-method
|
||||
"with: aColl
|
||||
| s |
|
||||
s := super new on: aColl.
|
||||
s setToEnd.
|
||||
^ s"))
|
||||
(st-class-add-class-method! "ReadWriteStream" "on:"
|
||||
(st-parse-method "on: aColl ^ super new on: aColl"))
|
||||
(st-class-add-method! "PositionableStream" "on:"
|
||||
(st-parse-method
|
||||
"on: aColl collection := aColl. position := 0. ^ self"))
|
||||
(st-class-add-method! "PositionableStream" "atEnd"
|
||||
(st-parse-method "atEnd ^ position >= collection size"))
|
||||
(st-class-add-method! "PositionableStream" "position"
|
||||
(st-parse-method "position ^ position"))
|
||||
(st-class-add-method! "PositionableStream" "position:"
|
||||
(st-parse-method "position: n position := n. ^ self"))
|
||||
(st-class-add-method! "PositionableStream" "reset"
|
||||
(st-parse-method "reset position := 0. ^ self"))
|
||||
(st-class-add-method! "PositionableStream" "setToEnd"
|
||||
(st-parse-method "setToEnd position := collection size. ^ self"))
|
||||
(st-class-add-method! "PositionableStream" "contents"
|
||||
(st-parse-method "contents ^ collection"))
|
||||
(st-class-add-method! "PositionableStream" "skip:"
|
||||
(st-parse-method "skip: n position := position + n. ^ self"))
|
||||
(st-class-add-method! "ReadStream" "next"
|
||||
(st-parse-method
|
||||
"next
|
||||
self atEnd ifTrue: [^ nil].
|
||||
position := position + 1.
|
||||
^ collection at: position"))
|
||||
(st-class-add-method! "ReadStream" "peek"
|
||||
(st-parse-method
|
||||
"peek
|
||||
self atEnd ifTrue: [^ nil].
|
||||
^ collection at: position + 1"))
|
||||
(st-class-add-method! "ReadStream" "upToEnd"
|
||||
(st-parse-method
|
||||
"upToEnd
|
||||
| result |
|
||||
result := Array new: 0.
|
||||
[self atEnd] whileFalse: [result add: self next].
|
||||
^ result"))
|
||||
(st-class-add-method! "ReadStream" "next:"
|
||||
(st-parse-method
|
||||
"next: n
|
||||
| result i |
|
||||
result := Array new: 0.
|
||||
i := 0.
|
||||
[(i < n) and: [self atEnd not]] whileTrue: [
|
||||
result add: self next.
|
||||
i := i + 1].
|
||||
^ result"))
|
||||
(st-class-add-method! "WriteStream" "nextPut:"
|
||||
(st-parse-method
|
||||
"nextPut: anObject
|
||||
collection add: anObject.
|
||||
position := position + 1.
|
||||
^ anObject"))
|
||||
(st-class-add-method! "WriteStream" "nextPutAll:"
|
||||
(st-parse-method
|
||||
"nextPutAll: aCollection
|
||||
aCollection do: [:e | self nextPut: e].
|
||||
^ aCollection"))
|
||||
;; ReadWriteStream inherits from WriteStream + ReadStream behaviour;
|
||||
;; for the simple linear-position model, both nextPut: and next work.
|
||||
(st-class-add-method! "ReadWriteStream" "next"
|
||||
(st-parse-method
|
||||
"next
|
||||
self atEnd ifTrue: [^ nil].
|
||||
position := position + 1.
|
||||
^ collection at: position"))
|
||||
(st-class-add-method! "ReadWriteStream" "peek"
|
||||
(st-parse-method
|
||||
"peek
|
||||
self atEnd ifTrue: [^ nil].
|
||||
^ collection at: position + 1"))
|
||||
;; ── Fraction ──
|
||||
;; Rational numbers stored as numerator/denominator, normalized
|
||||
;; (sign on numerator, denominator > 0, reduced via gcd).
|
||||
(st-class-add-class-method! "Fraction" "numerator:denominator:"
|
||||
(st-parse-method
|
||||
"numerator: n denominator: d
|
||||
| f |
|
||||
f := super new.
|
||||
^ f setNumerator: n denominator: d"))
|
||||
(st-class-add-method! "Fraction" "setNumerator:denominator:"
|
||||
(st-parse-method
|
||||
"setNumerator: n denominator: d
|
||||
| g s nn dd |
|
||||
d = 0 ifTrue: [Error signal: 'Fraction denominator cannot be zero'].
|
||||
s := (d < 0) ifTrue: [-1] ifFalse: [1].
|
||||
nn := n * s. dd := d * s.
|
||||
g := nn abs gcd: dd.
|
||||
g = 0 ifTrue: [g := 1].
|
||||
numerator := nn / g.
|
||||
denominator := dd / g.
|
||||
^ self"))
|
||||
(st-class-add-method! "Fraction" "numerator"
|
||||
(st-parse-method "numerator ^ numerator"))
|
||||
(st-class-add-method! "Fraction" "denominator"
|
||||
(st-parse-method "denominator ^ denominator"))
|
||||
(st-class-add-method! "Fraction" "+"
|
||||
(st-parse-method
|
||||
"+ other
|
||||
^ Fraction
|
||||
numerator: numerator * other denominator + (other numerator * denominator)
|
||||
denominator: denominator * other denominator"))
|
||||
(st-class-add-method! "Fraction" "-"
|
||||
(st-parse-method
|
||||
"- other
|
||||
^ Fraction
|
||||
numerator: numerator * other denominator - (other numerator * denominator)
|
||||
denominator: denominator * other denominator"))
|
||||
(st-class-add-method! "Fraction" "*"
|
||||
(st-parse-method
|
||||
"* other
|
||||
^ Fraction
|
||||
numerator: numerator * other numerator
|
||||
denominator: denominator * other denominator"))
|
||||
(st-class-add-method! "Fraction" "/"
|
||||
(st-parse-method
|
||||
"/ other
|
||||
^ Fraction
|
||||
numerator: numerator * other denominator
|
||||
denominator: denominator * other numerator"))
|
||||
(st-class-add-method! "Fraction" "negated"
|
||||
(st-parse-method
|
||||
"negated ^ Fraction numerator: numerator negated denominator: denominator"))
|
||||
(st-class-add-method! "Fraction" "reciprocal"
|
||||
(st-parse-method
|
||||
"reciprocal ^ Fraction numerator: denominator denominator: numerator"))
|
||||
(st-class-add-method! "Fraction" "="
|
||||
(st-parse-method
|
||||
"= other
|
||||
^ numerator = other numerator and: [denominator = other denominator]"))
|
||||
(st-class-add-method! "Fraction" "<"
|
||||
(st-parse-method
|
||||
"< other
|
||||
^ numerator * other denominator < (other numerator * denominator)"))
|
||||
(st-class-add-method! "Fraction" "asFloat"
|
||||
(st-parse-method "asFloat ^ numerator / denominator"))
|
||||
(st-class-add-method! "Fraction" "printString"
|
||||
(st-parse-method
|
||||
"printString ^ numerator printString , '/' , denominator printString"))
|
||||
(st-class-add-method! "Fraction" "isFraction"
|
||||
(st-parse-method "isFraction ^ true"))
|
||||
"ok")))
|
||||
|
||||
;; Initialise on load. Tests can re-bootstrap to reset state.
|
||||
(st-bootstrap-classes!)
|
||||
@@ -1,15 +0,0 @@
|
||||
{
|
||||
"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
|
||||
}
|
||||
@@ -1,56 +0,0 @@
|
||||
# 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.
|
||||
@@ -1,153 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,145 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# Fast Smalltalk-on-SX test runner — pipes directly to sx_server.exe.
|
||||
# Mirrors lib/haskell/test.sh.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/smalltalk/test.sh # run all tests
|
||||
# bash lib/smalltalk/test.sh -v # verbose
|
||||
# bash lib/smalltalk/test.sh tests/tokenize.sx # run one file
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
|
||||
if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
|
||||
SX_SERVER="$MAIN_ROOT/$SX_SERVER"
|
||||
else
|
||||
echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build"
|
||||
exit 1
|
||||
fi
|
||||
fi
|
||||
|
||||
VERBOSE=""
|
||||
FILES=()
|
||||
for arg in "$@"; do
|
||||
case "$arg" in
|
||||
-v|--verbose) VERBOSE=1 ;;
|
||||
*) FILES+=("$arg") ;;
|
||||
esac
|
||||
done
|
||||
|
||||
if [ ${#FILES[@]} -eq 0 ]; then
|
||||
# tokenize.sx must load first — it defines the st-test helpers reused by
|
||||
# subsequent test files. Sort enforces this lexicographically.
|
||||
mapfile -t FILES < <(find lib/smalltalk/tests -maxdepth 2 -name '*.sx' | sort)
|
||||
fi
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
FAILED_FILES=()
|
||||
|
||||
for FILE in "${FILES[@]}"; do
|
||||
[ -f "$FILE" ] || { echo "skip $FILE (not found)"; continue; }
|
||||
TMPFILE=$(mktemp)
|
||||
if [ "$(basename "$FILE")" = "tokenize.sx" ]; then
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
(eval "(list st-test-pass st-test-fail)")
|
||||
EPOCHS
|
||||
else
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "lib/smalltalk/parser.sx")
|
||||
(epoch 3)
|
||||
(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" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
(eval "(map (fn (f) (get f :name)) st-test-fails)")
|
||||
EPOCHS
|
||||
else
|
||||
cat > "$TMPFILE2" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "lib/smalltalk/parser.sx")
|
||||
(epoch 3)
|
||||
(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 "(map (fn (f) (get f :name)) st-test-fails)")
|
||||
EPOCHS
|
||||
fi
|
||||
FAILS=$(timeout 180 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok [0-9]+ \(' | tail -1 || true)
|
||||
rm -f "$TMPFILE2"
|
||||
echo " $FAILS"
|
||||
elif [ "$VERBOSE" = "1" ]; then
|
||||
printf 'OK %-40s %d passed\n' "$FILE" "$P"
|
||||
fi
|
||||
done
|
||||
|
||||
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
|
||||
if [ $TOTAL_FAIL -eq 0 ]; then
|
||||
echo "OK $TOTAL_PASS/$TOTAL smalltalk-on-sx tests passed"
|
||||
else
|
||||
echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed in: ${FAILED_FILES[*]}"
|
||||
fi
|
||||
|
||||
[ $TOTAL_FAIL -eq 0 ]
|
||||
@@ -1,158 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,92 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,96 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,115 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,104 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,107 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,181 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,122 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,216 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,78 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,92 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,152 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,131 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,369 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,294 +0,0 @@
|
||||
;; 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 <primitive: 60> ^ 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 <primitive: 1 module: '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 <primitive: -1> ^ 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 <category: #algebra> ^ 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 <primitive: 1> | 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 | <primitive: 1> 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 <primitive: 1> <category: 'a'> ^ 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)
|
||||
@@ -1,264 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,137 +0,0 @@
|
||||
"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! !
|
||||
@@ -1,89 +0,0 @@
|
||||
"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! !
|
||||
@@ -1,122 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,406 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,47 +0,0 @@
|
||||
"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! !
|
||||
@@ -1,23 +0,0 @@
|
||||
"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! !
|
||||
@@ -1,66 +0,0 @@
|
||||
"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! !
|
||||
@@ -1,36 +0,0 @@
|
||||
"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! !
|
||||
@@ -1,31 +0,0 @@
|
||||
"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! !
|
||||
@@ -1,304 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,255 +0,0 @@
|
||||
;; Smalltalk runtime tests — class table, type→class mapping, instances.
|
||||
;;
|
||||
;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset
|
||||
;; here so this file's summary covers runtime tests only.
|
||||
|
||||
(set! st-test-pass 0)
|
||||
(set! st-test-fail 0)
|
||||
(set! st-test-fails (list))
|
||||
|
||||
;; Fresh hierarchy for every test file.
|
||||
(st-bootstrap-classes!)
|
||||
|
||||
;; ── 1. Bootstrap installed expected classes ──
|
||||
(st-test "Object exists" (st-class-exists? "Object") true)
|
||||
(st-test "Behavior exists" (st-class-exists? "Behavior") true)
|
||||
(st-test "Metaclass exists" (st-class-exists? "Metaclass") true)
|
||||
(st-test "True/False/UndefinedObject"
|
||||
(and
|
||||
(st-class-exists? "True")
|
||||
(st-class-exists? "False")
|
||||
(st-class-exists? "UndefinedObject"))
|
||||
true)
|
||||
(st-test "SmallInteger / Float / Symbol exist"
|
||||
(and
|
||||
(st-class-exists? "SmallInteger")
|
||||
(st-class-exists? "Float")
|
||||
(st-class-exists? "Symbol"))
|
||||
true)
|
||||
(st-test "BlockClosure exists" (st-class-exists? "BlockClosure") true)
|
||||
|
||||
;; ── 2. Superclass chain ──
|
||||
(st-test "Object has no superclass" (st-class-superclass "Object") nil)
|
||||
(st-test "Behavior super = Object" (st-class-superclass "Behavior") "Object")
|
||||
(st-test "True super = Boolean" (st-class-superclass "True") "Boolean")
|
||||
(st-test "Symbol super = String" (st-class-superclass "Symbol") "String")
|
||||
(st-test
|
||||
"String chain"
|
||||
(st-class-chain "String")
|
||||
(list "String" "ArrayedCollection" "SequenceableCollection" "Collection" "Object"))
|
||||
(st-test
|
||||
"SmallInteger chain"
|
||||
(st-class-chain "SmallInteger")
|
||||
(list "SmallInteger" "Integer" "Number" "Magnitude" "Object"))
|
||||
|
||||
;; ── 3. inherits-from? ──
|
||||
(st-test "True inherits from Boolean" (st-class-inherits-from? "True" "Boolean") true)
|
||||
(st-test "True inherits from Object" (st-class-inherits-from? "True" "Object") true)
|
||||
(st-test "True inherits from True" (st-class-inherits-from? "True" "True") true)
|
||||
(st-test
|
||||
"True does not inherit from Number"
|
||||
(st-class-inherits-from? "True" "Number")
|
||||
false)
|
||||
(st-test
|
||||
"Object does not inherit from Number"
|
||||
(st-class-inherits-from? "Object" "Number")
|
||||
false)
|
||||
|
||||
;; ── 4. type→class mapping ──
|
||||
(st-test "class-of nil" (st-class-of nil) "UndefinedObject")
|
||||
(st-test "class-of true" (st-class-of true) "True")
|
||||
(st-test "class-of false" (st-class-of false) "False")
|
||||
(st-test "class-of int" (st-class-of 42) "SmallInteger")
|
||||
(st-test "class-of zero" (st-class-of 0) "SmallInteger")
|
||||
(st-test "class-of negative int" (st-class-of -3) "SmallInteger")
|
||||
(st-test "class-of float" (st-class-of 3.14) "Float")
|
||||
(st-test "class-of string" (st-class-of "hi") "String")
|
||||
(st-test "class-of symbol" (st-class-of (quote foo)) "Symbol")
|
||||
(st-test "class-of list" (st-class-of (list 1 2)) "Array")
|
||||
(st-test "class-of empty list" (st-class-of (list)) "Array")
|
||||
(st-test "class-of lambda" (st-class-of (fn (x) x)) "BlockClosure")
|
||||
(st-test "class-of dict" (st-class-of {:a 1}) "Dictionary")
|
||||
|
||||
;; ── 5. User class definition ──
|
||||
(st-class-define! "Account" "Object" (list "balance" "owner"))
|
||||
(st-class-define! "SavingsAccount" "Account" (list "rate"))
|
||||
|
||||
(st-test "Account exists" (st-class-exists? "Account") true)
|
||||
(st-test "Account super = Object" (st-class-superclass "Account") "Object")
|
||||
(st-test
|
||||
"SavingsAccount chain"
|
||||
(st-class-chain "SavingsAccount")
|
||||
(list "SavingsAccount" "Account" "Object"))
|
||||
(st-test
|
||||
"SavingsAccount own ivars"
|
||||
(get (st-class-get "SavingsAccount") :ivars)
|
||||
(list "rate"))
|
||||
(st-test
|
||||
"SavingsAccount inherited+own ivars"
|
||||
(st-class-all-ivars "SavingsAccount")
|
||||
(list "balance" "owner" "rate"))
|
||||
|
||||
;; ── 6. Instance construction ──
|
||||
(define a1 (st-make-instance "Account"))
|
||||
(st-test "instance is st-instance" (st-instance? a1) true)
|
||||
(st-test "instance class" (get a1 :class) "Account")
|
||||
(st-test "instance ivars start nil" (st-iv-get a1 "balance") nil)
|
||||
(st-test
|
||||
"instance has all expected ivars"
|
||||
(sort (keys (get a1 :ivars)))
|
||||
(sort (list "balance" "owner")))
|
||||
(define a2 (st-iv-set! a1 "balance" 100))
|
||||
(st-test "iv-set! returns updated copy" (st-iv-get a2 "balance") 100)
|
||||
(st-test "iv-set! does not mutate original" (st-iv-get a1 "balance") nil)
|
||||
(st-test "class-of instance" (st-class-of a1) "Account")
|
||||
|
||||
(define s1 (st-make-instance "SavingsAccount"))
|
||||
(st-test
|
||||
"subclass instance has all inherited ivars"
|
||||
(sort (keys (get s1 :ivars)))
|
||||
(sort (list "balance" "owner" "rate")))
|
||||
|
||||
;; ── 7. Method install + lookup ──
|
||||
(st-class-add-method!
|
||||
"Account"
|
||||
"balance"
|
||||
(st-parse-method "balance ^ balance"))
|
||||
(st-class-add-method!
|
||||
"Account"
|
||||
"deposit:"
|
||||
(st-parse-method "deposit: amount balance := balance + amount. ^ self"))
|
||||
|
||||
(st-test
|
||||
"method registered"
|
||||
(has-key? (get (st-class-get "Account") :methods) "balance")
|
||||
true)
|
||||
|
||||
(st-test
|
||||
"method lookup direct"
|
||||
(= (st-method-lookup "Account" "balance" false) nil)
|
||||
false)
|
||||
|
||||
(st-test
|
||||
"method lookup walks superclass"
|
||||
(= (st-method-lookup "SavingsAccount" "deposit:" false) nil)
|
||||
false)
|
||||
|
||||
(st-test
|
||||
"method lookup unknown selector"
|
||||
(st-method-lookup "Account" "frobnicate" false)
|
||||
nil)
|
||||
|
||||
(st-test
|
||||
"method lookup records defining class"
|
||||
(get (st-method-lookup "SavingsAccount" "balance" false) :defining-class)
|
||||
"Account")
|
||||
|
||||
;; SavingsAccount overrides deposit:
|
||||
(st-class-add-method!
|
||||
"SavingsAccount"
|
||||
"deposit:"
|
||||
(st-parse-method "deposit: amount ^ super deposit: amount + 1"))
|
||||
|
||||
(st-test
|
||||
"subclass override picked first"
|
||||
(get (st-method-lookup "SavingsAccount" "deposit:" false) :defining-class)
|
||||
"SavingsAccount")
|
||||
|
||||
(st-test
|
||||
"Account still finds its own deposit:"
|
||||
(get (st-method-lookup "Account" "deposit:" false) :defining-class)
|
||||
"Account")
|
||||
|
||||
;; ── 8. Class-side methods ──
|
||||
(st-class-add-class-method!
|
||||
"Account"
|
||||
"new"
|
||||
(st-parse-method "new ^ super new"))
|
||||
(st-test
|
||||
"class-side lookup"
|
||||
(= (st-method-lookup "Account" "new" true) nil)
|
||||
false)
|
||||
(st-test
|
||||
"instance-side does not find class method"
|
||||
(st-method-lookup "Account" "new" false)
|
||||
nil)
|
||||
|
||||
;; ── 9. Re-bootstrap resets table ──
|
||||
(st-bootstrap-classes!)
|
||||
(st-test "after re-bootstrap Account gone" (st-class-exists? "Account") false)
|
||||
(st-test "after re-bootstrap Object stays" (st-class-exists? "Object") true)
|
||||
|
||||
;; ── 10. Method-lookup cache ──
|
||||
(st-bootstrap-classes!)
|
||||
(st-class-define! "Foo" "Object" (list))
|
||||
(st-class-define! "Bar" "Foo" (list))
|
||||
(st-class-add-method! "Foo" "greet" (st-parse-method "greet ^ 1"))
|
||||
|
||||
;; Bootstrap clears cache; record stats from now.
|
||||
(st-method-cache-reset-stats!)
|
||||
|
||||
;; First lookup is a miss; second is a hit.
|
||||
(st-method-lookup "Bar" "greet" false)
|
||||
(st-test
|
||||
"first lookup recorded as miss"
|
||||
(get (st-method-cache-stats) :misses)
|
||||
1)
|
||||
(st-test
|
||||
"first lookup recorded as hit count zero"
|
||||
(get (st-method-cache-stats) :hits)
|
||||
0)
|
||||
|
||||
(st-method-lookup "Bar" "greet" false)
|
||||
(st-test
|
||||
"second lookup hits cache"
|
||||
(get (st-method-cache-stats) :hits)
|
||||
1)
|
||||
|
||||
;; Misses are also cached as :not-found.
|
||||
(st-method-lookup "Bar" "frobnicate" false)
|
||||
(st-method-lookup "Bar" "frobnicate" false)
|
||||
(st-test
|
||||
"negative-result caches"
|
||||
(get (st-method-cache-stats) :hits)
|
||||
2)
|
||||
|
||||
;; Adding a new method invalidates the cache.
|
||||
(st-class-add-method! "Bar" "greet" (st-parse-method "greet ^ 2"))
|
||||
(st-test
|
||||
"cache cleared on method add"
|
||||
(get (st-method-cache-stats) :size)
|
||||
0)
|
||||
(st-test
|
||||
"after invalidation lookup picks up override"
|
||||
(get (st-method-lookup "Bar" "greet" false) :defining-class)
|
||||
"Bar")
|
||||
|
||||
;; Removing a method also invalidates and exposes the inherited one.
|
||||
(st-class-remove-method! "Bar" "greet")
|
||||
(st-test
|
||||
"after remove lookup falls through to Foo"
|
||||
(get (st-method-lookup "Bar" "greet" false) :defining-class)
|
||||
"Foo")
|
||||
|
||||
;; Cache survives across unrelated class-table mutations? No — define! clears.
|
||||
(st-method-lookup "Foo" "greet" false) ; warm cache
|
||||
(st-class-define! "Baz" "Object" (list))
|
||||
(st-test
|
||||
"class-define clears cache"
|
||||
(get (st-method-cache-stats) :size)
|
||||
0)
|
||||
|
||||
;; Class-side and instance-side cache entries are separate keys.
|
||||
(st-class-add-class-method! "Foo" "make" (st-parse-method "make ^ self new"))
|
||||
(st-method-lookup "Foo" "make" true)
|
||||
(st-method-lookup "Foo" "make" false)
|
||||
(st-test
|
||||
"class-side hit found, instance-side stored as not-found"
|
||||
(= (st-method-lookup "Foo" "make" true) nil)
|
||||
false)
|
||||
(st-test
|
||||
"instance-side same selector returns nil"
|
||||
(st-method-lookup "Foo" "make" false)
|
||||
nil)
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
@@ -1,159 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,198 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,149 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,362 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,145 +0,0 @@
|
||||
;; 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)
|
||||
@@ -1,366 +0,0 @@
|
||||
;; 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)))
|
||||
41
lib/tcl/parser.sx
Normal file
41
lib/tcl/parser.sx
Normal file
@@ -0,0 +1,41 @@
|
||||
; Tcl parser — thin layer over tcl-tokenize
|
||||
; Adds tcl-parse entry point and word utility fns
|
||||
|
||||
; Entry point: parse Tcl source to a list of commands.
|
||||
; Returns same structure as tcl-tokenize.
|
||||
(define tcl-parse (fn (src) (tcl-tokenize src)))
|
||||
|
||||
; True if word has no substitutions — value can be read statically.
|
||||
; braced words are always simple. compound words are simple when all
|
||||
; parts are plain text with no var/cmd parts.
|
||||
(define tcl-word-simple?
|
||||
(fn (word)
|
||||
(cond
|
||||
((= (get word :type) "braced") true)
|
||||
((= (get word :type) "compound")
|
||||
(let ((parts (get word :parts)))
|
||||
(every? (fn (p) (= (get p :type) "text")) parts)))
|
||||
(else false))))
|
||||
|
||||
; Concatenate text parts of a simple word into a single string.
|
||||
; For braced words returns :value directly.
|
||||
; For compound words with only text parts, joins them.
|
||||
; Returns nil for words with substitutions.
|
||||
(define tcl-word-literal
|
||||
(fn (word)
|
||||
(cond
|
||||
((= (get word :type) "braced") (get word :value))
|
||||
((= (get word :type) "compound")
|
||||
(if (tcl-word-simple? word)
|
||||
(join "" (map (fn (p) (get p :value)) (get word :parts)))
|
||||
nil))
|
||||
(else nil))))
|
||||
|
||||
; Number of words in a parsed command.
|
||||
(define tcl-cmd-len
|
||||
(fn (cmd) (len (get cmd :words))))
|
||||
|
||||
; Nth word literal from a command (index 0 = command name).
|
||||
; Returns nil if word has substitutions.
|
||||
(define tcl-nth-literal
|
||||
(fn (cmd n) (tcl-word-literal (nth (get cmd :words) n))))
|
||||
53
lib/tcl/test.sh
Executable file
53
lib/tcl/test.sh
Executable file
@@ -0,0 +1,53 @@
|
||||
#!/usr/bin/env bash
|
||||
# Tcl-on-SX test runner — epoch protocol to sx_server.exe
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
fi
|
||||
if [ ! -x "$SX_SERVER" ]; then echo "ERROR: sx_server.exe not found"; exit 1; fi
|
||||
|
||||
VERBOSE="${1:-}"
|
||||
TMPFILE=$(mktemp)
|
||||
trap "rm -f $TMPFILE" EXIT
|
||||
|
||||
cat > "$TMPFILE" << 'EPOCHS'
|
||||
(epoch 1)
|
||||
(load "lib/tcl/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "lib/tcl/parser.sx")
|
||||
(epoch 3)
|
||||
(load "lib/tcl/tests/parse.sx")
|
||||
(epoch 4)
|
||||
(eval "(tcl-run-parse-tests)")
|
||||
EPOCHS
|
||||
|
||||
OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
|
||||
|
||||
# Result follows an (ok-len 3 N) line
|
||||
RESULT=$(echo "$OUTPUT" | grep -A1 "^(ok-len 4 " | tail -1)
|
||||
if [ -z "$RESULT" ]; then
|
||||
RESULT=$(echo "$OUTPUT" | grep "^(ok 4 " | sed 's/^(ok 3 //' | sed 's/)$//')
|
||||
fi
|
||||
if [ -z "$RESULT" ]; then
|
||||
echo "ERROR: no result from epoch 4"
|
||||
echo "$OUTPUT" | tail -10
|
||||
exit 1
|
||||
fi
|
||||
|
||||
PASSED=$(echo "$RESULT" | grep -o ':passed [0-9]*' | grep -o '[0-9]*$')
|
||||
FAILED=$(echo "$RESULT" | grep -o ':failed [0-9]*' | grep -o '[0-9]*$')
|
||||
PASSED=${PASSED:-0}; FAILED=${FAILED:-1}
|
||||
TOTAL=$((PASSED + FAILED))
|
||||
|
||||
if [ "$FAILED" = "0" ]; then
|
||||
echo "ok $PASSED/$TOTAL tcl-tokenize tests passed"
|
||||
exit 0
|
||||
else
|
||||
echo "FAIL $PASSED/$TOTAL passed, $FAILED failed"
|
||||
echo "$RESULT"
|
||||
exit 1
|
||||
fi
|
||||
186
lib/tcl/tests/parse.sx
Normal file
186
lib/tcl/tests/parse.sx
Normal file
@@ -0,0 +1,186 @@
|
||||
(define tcl-parse-pass 0)
|
||||
(define tcl-parse-fail 0)
|
||||
(define tcl-parse-failures (list))
|
||||
|
||||
(define tcl-assert
|
||||
(fn (label expected actual)
|
||||
(if (= expected actual)
|
||||
(set! tcl-parse-pass (+ tcl-parse-pass 1))
|
||||
(begin
|
||||
(set! tcl-parse-fail (+ tcl-parse-fail 1))
|
||||
(append! tcl-parse-failures
|
||||
(str label ": expected=" (str expected) " got=" (str actual)))))))
|
||||
|
||||
(define tcl-first-cmd
|
||||
(fn (src) (nth (tcl-tokenize src) 0)))
|
||||
|
||||
(define tcl-cmd-words
|
||||
(fn (src) (get (tcl-first-cmd src) :words)))
|
||||
|
||||
(define tcl-word
|
||||
(fn (src wi) (nth (tcl-cmd-words src) wi)))
|
||||
|
||||
(define tcl-parts
|
||||
(fn (src wi) (get (tcl-word src wi) :parts)))
|
||||
|
||||
(define tcl-part
|
||||
(fn (src wi pi) (nth (tcl-parts src wi) pi)))
|
||||
|
||||
(define tcl-run-parse-tests
|
||||
(fn ()
|
||||
(set! tcl-parse-pass 0)
|
||||
(set! tcl-parse-fail 0)
|
||||
(set! tcl-parse-failures (list))
|
||||
|
||||
; empty / whitespace-only
|
||||
(tcl-assert "empty" 0 (len (tcl-tokenize "")))
|
||||
(tcl-assert "ws-only" 0 (len (tcl-tokenize " ")))
|
||||
(tcl-assert "nl-only" 0 (len (tcl-tokenize "\n\n")))
|
||||
|
||||
; single command word count
|
||||
(tcl-assert "1word" 1 (len (tcl-cmd-words "set")))
|
||||
(tcl-assert "3words" 3 (len (tcl-cmd-words "set x 1")))
|
||||
(tcl-assert "4words" 4 (len (tcl-cmd-words "set a b c")))
|
||||
|
||||
; word type — bare word is compound
|
||||
(tcl-assert "bare-type" "compound" (get (tcl-word "set x 1" 0) :type))
|
||||
(tcl-assert "bare-quoted" false (get (tcl-word "set x 1" 0) :quoted))
|
||||
(tcl-assert "bare-part-type" "text" (get (tcl-part "set x 1" 0 0) :type))
|
||||
(tcl-assert "bare-part-val" "set" (get (tcl-part "set x 1" 0 0) :value))
|
||||
(tcl-assert "bare-part2-val" "x" (get (tcl-part "set x 1" 1 0) :value))
|
||||
(tcl-assert "bare-part3-val" "1" (get (tcl-part "set x 1" 2 0) :value))
|
||||
|
||||
; multiple commands
|
||||
(tcl-assert "semi-sep" 2 (len (tcl-tokenize "set x 1; set y 2")))
|
||||
(tcl-assert "nl-sep" 2 (len (tcl-tokenize "set x 1\nset y 2")))
|
||||
(tcl-assert "multi-nl" 3 (len (tcl-tokenize "a\nb\nc")))
|
||||
|
||||
; comments
|
||||
(tcl-assert "comment-only" 0 (len (tcl-tokenize "# comment")))
|
||||
(tcl-assert "comment-nl" 0 (len (tcl-tokenize "# comment\n")))
|
||||
(tcl-assert "comment-then-cmd" 1 (len (tcl-tokenize "# comment\nset x 1")))
|
||||
(tcl-assert "semi-then-comment" 1 (len (tcl-tokenize "set x 1; # comment")))
|
||||
|
||||
; brace-quoted words
|
||||
(tcl-assert "brace-type" "braced" (get (tcl-word "{hello}" 0) :type))
|
||||
(tcl-assert "brace-value" "hello" (get (tcl-word "{hello}" 0) :value))
|
||||
(tcl-assert "brace-spaces" "hello world" (get (tcl-word "{hello world}" 0) :value))
|
||||
(tcl-assert "brace-nested" "a {b} c" (get (tcl-word "{a {b} c}" 0) :value))
|
||||
(tcl-assert "brace-no-var-sub" "hello $x" (get (tcl-word "{hello $x}" 0) :value))
|
||||
(tcl-assert "brace-no-cmd-sub" "[expr 1]" (get (tcl-word "{[expr 1]}" 0) :value))
|
||||
|
||||
; double-quoted words
|
||||
(tcl-assert "dq-type" "compound" (get (tcl-word "\"hello\"" 0) :type))
|
||||
(tcl-assert "dq-quoted" true (get (tcl-word "\"hello\"" 0) :quoted))
|
||||
(tcl-assert "dq-literal" "hello" (get (tcl-part "\"hello\"" 0 0) :value))
|
||||
|
||||
; variable substitution in bare word
|
||||
(tcl-assert "var-type" "var" (get (tcl-part "$x" 0 0) :type))
|
||||
(tcl-assert "var-name" "x" (get (tcl-part "$x" 0 0) :name))
|
||||
(tcl-assert "var-long" "long_name" (get (tcl-part "$long_name" 0 0) :name))
|
||||
|
||||
; ${name} form
|
||||
(tcl-assert "var-brace-type" "var" (get (tcl-part "${x}" 0 0) :type))
|
||||
(tcl-assert "var-brace-name" "x" (get (tcl-part "${x}" 0 0) :name))
|
||||
|
||||
; array variable substitution
|
||||
(tcl-assert "arr-type" "var-arr" (get (tcl-part "$arr(key)" 0 0) :type))
|
||||
(tcl-assert "arr-name" "arr" (get (tcl-part "$arr(key)" 0 0) :name))
|
||||
(tcl-assert "arr-key-len" 1 (len (get (tcl-part "$arr(key)" 0 0) :key)))
|
||||
(tcl-assert "arr-key-text" "key"
|
||||
(get (nth (get (tcl-part "$arr(key)" 0 0) :key) 0) :value))
|
||||
|
||||
; command substitution
|
||||
(tcl-assert "cmd-type" "cmd" (get (tcl-part "[expr 1+1]" 0 0) :type))
|
||||
(tcl-assert "cmd-src" "expr 1+1" (get (tcl-part "[expr 1+1]" 0 0) :src))
|
||||
|
||||
; nested command substitution
|
||||
(tcl-assert "cmd-nested-src" "expr [string length x]"
|
||||
(get (tcl-part "[expr [string length x]]" 0 0) :src))
|
||||
|
||||
; backslash substitution in double-quoted word
|
||||
(let ((ps (tcl-parts "\"a\\nb\"" 0)))
|
||||
(begin
|
||||
(tcl-assert "bs-n-part0" "a" (get (nth ps 0) :value))
|
||||
(tcl-assert "bs-n-part1" "\n" (get (nth ps 1) :value))
|
||||
(tcl-assert "bs-n-part2" "b" (get (nth ps 2) :value))))
|
||||
|
||||
(let ((ps (tcl-parts "\"a\\tb\"" 0)))
|
||||
(tcl-assert "bs-t-part1" "\t" (get (nth ps 1) :value)))
|
||||
|
||||
(let ((ps (tcl-parts "\"a\\\\b\"" 0)))
|
||||
(tcl-assert "bs-bs-part1" "\\" (get (nth ps 1) :value)))
|
||||
|
||||
; mixed word: text + var + text in double-quoted
|
||||
(let ((ps (tcl-parts "\"hello $name!\"" 0)))
|
||||
(begin
|
||||
(tcl-assert "mixed-text0" "hello " (get (nth ps 0) :value))
|
||||
(tcl-assert "mixed-var1-type" "var" (get (nth ps 1) :type))
|
||||
(tcl-assert "mixed-var1-name" "name" (get (nth ps 1) :name))
|
||||
(tcl-assert "mixed-text2" "!" (get (nth ps 2) :value))))
|
||||
|
||||
; {*} expansion
|
||||
(tcl-assert "expand-type" "expand" (get (tcl-word "{*}$list" 0) :type))
|
||||
|
||||
; line continuation between words
|
||||
(tcl-assert "cont-words" 3 (len (tcl-cmd-words "set x \\\n 1")))
|
||||
|
||||
; continuation — third command word is correct
|
||||
(tcl-assert "cont-word2-val" "1"
|
||||
(get (tcl-part "set x \\\n 1" 2 0) :value))
|
||||
|
||||
|
||||
; --- parser helpers ---
|
||||
; tcl-parse is an alias for tcl-tokenize
|
||||
(tcl-assert "parse-cmd-count" 1 (len (tcl-parse "set x 1")))
|
||||
(tcl-assert "parse-2cmds" 2 (len (tcl-parse "set x 1; set y 2")))
|
||||
|
||||
; tcl-cmd-len
|
||||
(tcl-assert "cmd-len-3" 3 (tcl-cmd-len (nth (tcl-parse "set x 1") 0)))
|
||||
(tcl-assert "cmd-len-1" 1 (tcl-cmd-len (nth (tcl-parse "puts") 0)))
|
||||
|
||||
; tcl-word-simple? on braced word
|
||||
(tcl-assert "simple-braced" true
|
||||
(tcl-word-simple? (nth (get (nth (tcl-parse "{hello}") 0) :words) 0)))
|
||||
|
||||
; tcl-word-simple? on bare word with no subs
|
||||
(tcl-assert "simple-bare" true
|
||||
(tcl-word-simple? (nth (get (nth (tcl-parse "hello") 0) :words) 0)))
|
||||
|
||||
; tcl-word-simple? on word containing a var sub — false
|
||||
(tcl-assert "simple-var-false" false
|
||||
(tcl-word-simple? (nth (get (nth (tcl-parse "$x") 0) :words) 0)))
|
||||
|
||||
; tcl-word-simple? on word containing a cmd sub — false
|
||||
(tcl-assert "simple-cmd-false" false
|
||||
(tcl-word-simple? (nth (get (nth (tcl-parse "[expr 1]") 0) :words) 0)))
|
||||
|
||||
; tcl-word-literal on braced word
|
||||
(tcl-assert "lit-braced" "hello world"
|
||||
(tcl-word-literal (nth (get (nth (tcl-parse "{hello world}") 0) :words) 0)))
|
||||
|
||||
; tcl-word-literal on bare word
|
||||
(tcl-assert "lit-bare" "hello"
|
||||
(tcl-word-literal (nth (get (nth (tcl-parse "hello") 0) :words) 0)))
|
||||
|
||||
; tcl-word-literal on word with var sub returns nil
|
||||
(tcl-assert "lit-var-nil" nil
|
||||
(tcl-word-literal (nth (get (nth (tcl-parse "$x") 0) :words) 0)))
|
||||
|
||||
; tcl-nth-literal
|
||||
(tcl-assert "nth-lit-0" "set"
|
||||
(tcl-nth-literal (nth (tcl-parse "set x 1") 0) 0))
|
||||
(tcl-assert "nth-lit-1" "x"
|
||||
(tcl-nth-literal (nth (tcl-parse "set x 1") 0) 1))
|
||||
(tcl-assert "nth-lit-2" "1"
|
||||
(tcl-nth-literal (nth (tcl-parse "set x 1") 0) 2))
|
||||
|
||||
; tcl-nth-literal returns nil when word has subs
|
||||
(tcl-assert "nth-lit-nil" nil
|
||||
(tcl-nth-literal (nth (tcl-parse "set x $y") 0) 2))
|
||||
|
||||
|
||||
(dict
|
||||
"passed" tcl-parse-pass
|
||||
"failed" tcl-parse-fail
|
||||
"failures" tcl-parse-failures)))
|
||||
308
lib/tcl/tokenizer.sx
Normal file
308
lib/tcl/tokenizer.sx
Normal file
@@ -0,0 +1,308 @@
|
||||
(define tcl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\r"))))
|
||||
|
||||
(define tcl-alpha?
|
||||
(fn (c)
|
||||
(and
|
||||
(not (= c nil))
|
||||
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
|
||||
|
||||
(define tcl-digit?
|
||||
(fn (c) (and (not (= c nil)) (>= c "0") (<= c "9"))))
|
||||
|
||||
(define tcl-ident-start?
|
||||
(fn (c) (or (tcl-alpha? c) (= c "_"))))
|
||||
|
||||
(define tcl-ident-char?
|
||||
(fn (c) (or (tcl-ident-start? c) (tcl-digit? c))))
|
||||
|
||||
(define tcl-tokenize
|
||||
(fn (src)
|
||||
(let ((pos 0) (src-len (len src)) (commands (list)))
|
||||
|
||||
(define char-at
|
||||
(fn (off)
|
||||
(if (< (+ pos off) src-len) (nth src (+ pos off)) nil)))
|
||||
|
||||
(define cur (fn () (char-at 0)))
|
||||
|
||||
(define advance! (fn (n) (set! pos (+ pos n))))
|
||||
|
||||
(define skip-ws!
|
||||
(fn ()
|
||||
(when (tcl-ws? (cur))
|
||||
(begin (advance! 1) (skip-ws!)))))
|
||||
|
||||
(define skip-to-eol!
|
||||
(fn ()
|
||||
(when (and (< pos src-len) (not (= (cur) "\n")))
|
||||
(begin (advance! 1) (skip-to-eol!)))))
|
||||
|
||||
(define skip-brace-content!
|
||||
(fn (d)
|
||||
(when (and (< pos src-len) (> d 0))
|
||||
(cond
|
||||
((= (cur) "{") (begin (advance! 1) (skip-brace-content! (+ d 1))))
|
||||
((= (cur) "}") (begin (advance! 1) (skip-brace-content! (- d 1))))
|
||||
(else (begin (advance! 1) (skip-brace-content! d)))))))
|
||||
|
||||
(define skip-dquote-content!
|
||||
(fn ()
|
||||
(when (and (< pos src-len) (not (= (cur) "\"")))
|
||||
(begin
|
||||
(when (= (cur) "\\") (advance! 1))
|
||||
(when (< pos src-len) (advance! 1))
|
||||
(skip-dquote-content!)))))
|
||||
|
||||
(define parse-bs
|
||||
(fn ()
|
||||
(advance! 1)
|
||||
(let ((c (cur)))
|
||||
(cond
|
||||
((= c nil) "\\")
|
||||
((= c "n") (begin (advance! 1) "\n"))
|
||||
((= c "t") (begin (advance! 1) "\t"))
|
||||
((= c "r") (begin (advance! 1) "\r"))
|
||||
((= c "\\") (begin (advance! 1) "\\"))
|
||||
((= c "[") (begin (advance! 1) "["))
|
||||
((= c "]") (begin (advance! 1) "]"))
|
||||
((= c "{") (begin (advance! 1) "{"))
|
||||
((= c "}") (begin (advance! 1) "}"))
|
||||
((= c "$") (begin (advance! 1) "$"))
|
||||
((= c ";") (begin (advance! 1) ";"))
|
||||
((= c "\"") (begin (advance! 1) "\""))
|
||||
((= c "'") (begin (advance! 1) "'"))
|
||||
((= c " ") (begin (advance! 1) " "))
|
||||
((= c "\n")
|
||||
(begin
|
||||
(advance! 1)
|
||||
(skip-ws!)
|
||||
" "))
|
||||
(else (begin (advance! 1) (str "\\" c)))))))
|
||||
|
||||
(define parse-cmd-sub
|
||||
(fn ()
|
||||
(advance! 1)
|
||||
(let ((start pos) (depth 1))
|
||||
(define scan!
|
||||
(fn ()
|
||||
(when (and (< pos src-len) (> depth 0))
|
||||
(cond
|
||||
((= (cur) "[")
|
||||
(begin (set! depth (+ depth 1)) (advance! 1) (scan!)))
|
||||
((= (cur) "]")
|
||||
(begin
|
||||
(set! depth (- depth 1))
|
||||
(when (> depth 0) (advance! 1))
|
||||
(scan!)))
|
||||
((= (cur) "{")
|
||||
(begin (advance! 1) (skip-brace-content! 1) (scan!)))
|
||||
((= (cur) "\"")
|
||||
(begin
|
||||
(advance! 1)
|
||||
(skip-dquote-content!)
|
||||
(when (= (cur) "\"") (advance! 1))
|
||||
(scan!)))
|
||||
((= (cur) "\\")
|
||||
(begin (advance! 1) (when (< pos src-len) (advance! 1)) (scan!)))
|
||||
(else (begin (advance! 1) (scan!)))))))
|
||||
(scan!)
|
||||
(let ((src-text (slice src start pos)))
|
||||
(begin
|
||||
(when (= (cur) "]") (advance! 1))
|
||||
{:type "cmd" :src src-text})))))
|
||||
|
||||
(define scan-name!
|
||||
(fn ()
|
||||
(when (and (< pos src-len) (not (= (cur) "}")))
|
||||
(begin (advance! 1) (scan-name!)))))
|
||||
|
||||
(define scan-ns-name!
|
||||
(fn ()
|
||||
(cond
|
||||
((tcl-ident-char? (cur))
|
||||
(begin (advance! 1) (scan-ns-name!)))
|
||||
((and (= (cur) ":") (= (char-at 1) ":"))
|
||||
(begin (advance! 2) (scan-ns-name!)))
|
||||
(else nil))))
|
||||
|
||||
(define scan-klit!
|
||||
(fn ()
|
||||
(when (and (< pos src-len)
|
||||
(not (= (cur) ")"))
|
||||
(not (= (cur) "$"))
|
||||
(not (= (cur) "["))
|
||||
(not (= (cur) "\\")))
|
||||
(begin (advance! 1) (scan-klit!)))))
|
||||
|
||||
(define scan-key!
|
||||
(fn (kp)
|
||||
(when (and (< pos src-len) (not (= (cur) ")")))
|
||||
(cond
|
||||
((= (cur) "$")
|
||||
(begin (append! kp (parse-var-sub)) (scan-key! kp)))
|
||||
((= (cur) "[")
|
||||
(begin (append! kp (parse-cmd-sub)) (scan-key! kp)))
|
||||
((= (cur) "\\")
|
||||
(begin
|
||||
(append! kp {:type "text" :value (parse-bs)})
|
||||
(scan-key! kp)))
|
||||
(else
|
||||
(let ((kstart pos))
|
||||
(begin
|
||||
(scan-klit!)
|
||||
(append! kp {:type "text" :value (slice src kstart pos)})
|
||||
(scan-key! kp))))))))
|
||||
|
||||
(define parse-var-sub
|
||||
(fn ()
|
||||
(advance! 1)
|
||||
(cond
|
||||
((= (cur) "{")
|
||||
(begin
|
||||
(advance! 1)
|
||||
(let ((start pos))
|
||||
(begin
|
||||
(scan-name!)
|
||||
(let ((name (slice src start pos)))
|
||||
(begin
|
||||
(when (= (cur) "}") (advance! 1))
|
||||
{:type "var" :name name}))))))
|
||||
((tcl-ident-start? (cur))
|
||||
(let ((start pos))
|
||||
(begin
|
||||
(scan-ns-name!)
|
||||
(let ((name (slice src start pos)))
|
||||
(if (= (cur) "(")
|
||||
(begin
|
||||
(advance! 1)
|
||||
(let ((key-parts (list)))
|
||||
(begin
|
||||
(scan-key! key-parts)
|
||||
(when (= (cur) ")") (advance! 1))
|
||||
{:type "var-arr" :name name :key key-parts})))
|
||||
{:type "var" :name name})))))
|
||||
(else {:type "text" :value "$"}))))
|
||||
|
||||
(define scan-lit!
|
||||
(fn (stop?)
|
||||
(when (and (< pos src-len)
|
||||
(not (stop? (cur)))
|
||||
(not (= (cur) "$"))
|
||||
(not (= (cur) "["))
|
||||
(not (= (cur) "\\")))
|
||||
(begin (advance! 1) (scan-lit! stop?)))))
|
||||
|
||||
(define parse-word-parts!
|
||||
(fn (parts stop?)
|
||||
(when (and (< pos src-len) (not (stop? (cur))))
|
||||
(cond
|
||||
((= (cur) "$")
|
||||
(begin (append! parts (parse-var-sub)) (parse-word-parts! parts stop?)))
|
||||
((= (cur) "[")
|
||||
(begin (append! parts (parse-cmd-sub)) (parse-word-parts! parts stop?)))
|
||||
((= (cur) "\\")
|
||||
(begin
|
||||
(append! parts {:type "text" :value (parse-bs)})
|
||||
(parse-word-parts! parts stop?)))
|
||||
(else
|
||||
(let ((start pos))
|
||||
(begin
|
||||
(scan-lit! stop?)
|
||||
(when (> pos start)
|
||||
(append! parts {:type "text" :value (slice src start pos)}))
|
||||
(parse-word-parts! parts stop?))))))))
|
||||
|
||||
(define parse-brace-word
|
||||
(fn ()
|
||||
(advance! 1)
|
||||
(let ((depth 1) (start pos))
|
||||
(define scan!
|
||||
(fn ()
|
||||
(when (and (< pos src-len) (> depth 0))
|
||||
(cond
|
||||
((= (cur) "{")
|
||||
(begin (set! depth (+ depth 1)) (advance! 1) (scan!)))
|
||||
((= (cur) "}")
|
||||
(begin (set! depth (- depth 1)) (when (> depth 0) (advance! 1)) (scan!)))
|
||||
(else (begin (advance! 1) (scan!)))))))
|
||||
(scan!)
|
||||
(let ((value (slice src start pos)))
|
||||
(begin
|
||||
(when (= (cur) "}") (advance! 1))
|
||||
{:type "braced" :value value})))))
|
||||
|
||||
(define parse-dquote-word
|
||||
(fn ()
|
||||
(advance! 1)
|
||||
(let ((parts (list)))
|
||||
(begin
|
||||
(parse-word-parts! parts (fn (c) (or (= c "\"") (= c nil))))
|
||||
(when (= (cur) "\"") (advance! 1))
|
||||
{:type "compound" :parts parts :quoted true}))))
|
||||
|
||||
(define parse-bare-word
|
||||
(fn ()
|
||||
(let ((parts (list)))
|
||||
(begin
|
||||
(parse-word-parts!
|
||||
parts
|
||||
(fn (c) (or (tcl-ws? c) (= c "\n") (= c ";") (= c nil))))
|
||||
{:type "compound" :parts parts :quoted false}))))
|
||||
|
||||
(define parse-word-no-expand
|
||||
(fn ()
|
||||
(cond
|
||||
((= (cur) "{") (parse-brace-word))
|
||||
((= (cur) "\"") (parse-dquote-word))
|
||||
(else (parse-bare-word)))))
|
||||
|
||||
(define parse-word
|
||||
(fn ()
|
||||
(cond
|
||||
((and (= (cur) "{") (= (char-at 1) "*") (= (char-at 2) "}"))
|
||||
(begin
|
||||
(advance! 3)
|
||||
{:type "expand" :word (parse-word-no-expand)}))
|
||||
((= (cur) "{") (parse-brace-word))
|
||||
((= (cur) "\"") (parse-dquote-word))
|
||||
(else (parse-bare-word)))))
|
||||
|
||||
(define parse-words!
|
||||
(fn (words)
|
||||
(skip-ws!)
|
||||
(cond
|
||||
((or (= (cur) nil) (= (cur) "\n") (= (cur) ";")) nil)
|
||||
((and (= (cur) "\\") (= (char-at 1) "\n"))
|
||||
(begin (advance! 2) (skip-ws!) (parse-words! words)))
|
||||
(else
|
||||
(begin
|
||||
(append! words (parse-word))
|
||||
(parse-words! words))))))
|
||||
|
||||
(define skip-seps!
|
||||
(fn ()
|
||||
(when (< pos src-len)
|
||||
(cond
|
||||
((or (tcl-ws? (cur)) (= (cur) "\n") (= (cur) ";"))
|
||||
(begin (advance! 1) (skip-seps!)))
|
||||
((and (= (cur) "\\") (= (char-at 1) "\n"))
|
||||
(begin (advance! 2) (skip-seps!)))
|
||||
(else nil)))))
|
||||
|
||||
(define parse-all!
|
||||
(fn ()
|
||||
(skip-seps!)
|
||||
(when (< pos src-len)
|
||||
(cond
|
||||
((= (cur) "#")
|
||||
(begin (skip-to-eol!) (parse-all!)))
|
||||
(else
|
||||
(let ((words (list)))
|
||||
(begin
|
||||
(parse-words! words)
|
||||
(when (> (len words) 0)
|
||||
(append! commands {:type "command" :words words}))
|
||||
(parse-all!))))))))
|
||||
|
||||
(parse-all!)
|
||||
commands)))
|
||||
81
plans/agent-briefings/apl-loop.md
Normal file
81
plans/agent-briefings/apl-loop.md
Normal file
@@ -0,0 +1,81 @@
|
||||
# apl-on-sx loop agent (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/apl-on-sx.md` forever. Rank-polymorphic primitives + 6 operators on the JIT is the headline showcase — APL is the densest combinator algebra you can put on top of a primitive table. Every program is `array → array` pure pipelines, exactly what the JIT was built for.
|
||||
|
||||
```
|
||||
description: apl-on-sx queue loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/apl-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
1. Read `plans/apl-on-sx.md` — roadmap + Progress log.
|
||||
2. `ls lib/apl/` — pick up from the most advanced file.
|
||||
3. If `lib/apl/tests/*.sx` exist, run them. Green before new work.
|
||||
4. If `lib/apl/scoreboard.md` exists, that's your baseline.
|
||||
|
||||
## The queue
|
||||
|
||||
Phase order per `plans/apl-on-sx.md`:
|
||||
|
||||
- **Phase 1** — tokenizer + parser. Unicode glyphs, `¯` for negative, strands (juxtaposition), right-to-left, valence resolution by syntactic position
|
||||
- **Phase 2** — array model + scalar primitives. `make-array {shape, ravel}`, scalar promotion, broadcast for `+ - × ÷ ⌈ ⌊ * ⍟ | ! ○`, comparison, logical, `⍳`, `⎕IO`
|
||||
- **Phase 3** — structural primitives + indexing. `⍴ , ⍉ ↑ ↓ ⌽ ⊖ ⌷ ⍋ ⍒ ⊂ ⊃ ∊`
|
||||
- **Phase 4** — **THE SHOWCASE**: operators. `f/` (reduce), `f¨` (each), `∘.f` (outer), `f.g` (inner), `f⍨` (commute), `f∘g` (compose), `f⍣n` (power), `f⍤k` (rank), `@` (at)
|
||||
- **Phase 5** — dfns + tradfns + control flow. `{⍺+⍵}`, `∇` recurse, `⍺←default`, tradfn header, `:If/:While/:For/:Select`
|
||||
- **Phase 6** — classic programs (life, mandelbrot, primes, n-queens, quicksort) + idiom corpus + drive to 100+
|
||||
|
||||
Within a phase, pick the checkbox that unlocks the most tests per effort.
|
||||
|
||||
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Scope:** only `lib/apl/**` and `plans/apl-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. APL primitives go in `lib/apl/runtime.sx`.
|
||||
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Unicode in `.sx`:** raw UTF-8 only, never `\uXXXX` escapes. Glyphs land directly in source.
|
||||
- **Worktree:** commit locally. Never push. Never touch `main`.
|
||||
- **Commit granularity:** one feature per commit.
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
|
||||
## APL-specific gotchas
|
||||
|
||||
- **Right-to-left, no precedence among functions.** `2 × 3 + 4` is `2 × (3 + 4)` = 14, not 10. Operators bind tighter than functions: `+/ ⍳5` is `+/(⍳5)`, and `2 +.× 3 4` is `2 (+.×) 3 4`.
|
||||
- **Valence by position.** `-3` is monadic negate (`-` with no left arg). `5-3` is dyadic subtract. The parser must look left to decide. Same glyph; different fn.
|
||||
- **`¯` is part of a number literal**, not a prefix function. `¯3` is the literal negative three; `-3` is the function call. Tokenizer eats `¯` into the numeric token.
|
||||
- **Strands.** `1 2 3` is a 3-element vector, not three separate calls. Adjacent literals fuse into a strand at parse time. Adjacent names do *not* fuse — `a b c` is three separate references.
|
||||
- **Scalar promotion.** `1 + 2 3 4` ↦ `3 4 5`. Any scalar broadcasts against any-rank conformable shape.
|
||||
- **Conformability** = exactly matching shapes, OR one side scalar, OR (in some dialects) one side rank-1 cycling against rank-N. Keep strict in v1: matching shape or scalar only.
|
||||
- **`⍳` is overloaded.** Monadic `⍳N` = vector 1..N (or 0..N-1 if `⎕IO=0`). Dyadic `V ⍳ W` = first-index lookup, returns `≢V+1` for not-found.
|
||||
- **Reduce with `+/⍳0`** = `0` (identity for `+`). Each scalar primitive has a defined identity used by reduce-on-empty. Don't crash; return identity.
|
||||
- **Reduce direction.** `f/` reduces the *last* axis. `f⌿` reduces the *first*. Matters for matrices.
|
||||
- **Indexing is 1-based** by default (`⎕IO=1`). Do not silently translate to 0-based; respect `⎕IO`.
|
||||
- **Bracket indexing** `A[I]` is sugar for `I⌷A` (squad-quad). Multi-axis: `A[I;J]` is `I J⌷A` with semicolon-separated axes; `A[;J]` selects all of axis 0.
|
||||
- **Dfn `{...}`** — `⍺` = left arg (may be unbound for monadic call → check with `⍺←default`), `⍵` = right arg, `∇` = recurse. Default left arg syntax: `⍺←0`.
|
||||
- **Tradfn vs dfn** — tradfns use line-numbered `→linenum` for goto; dfns use guards `cond:expr`. Pick the right one for the user's syntax.
|
||||
- **Empty array** = rank-N array where some dim is 0. `0⍴⍳0` is empty rank-1. Scalar prototype matters for empty-array operations; ignore in v1, return 0/space.
|
||||
- **Test corpus:** custom + idioms. Place programs in `lib/apl/tests/programs/` with `.apl` extension.
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` clauses evaluate only the last expr.
|
||||
- `type-of` on user fn returns `"lambda"`.
|
||||
- Shell heredoc `||` gets eaten — escape or use `case`.
|
||||
|
||||
## Style
|
||||
|
||||
- No comments in `.sx` unless non-obvious.
|
||||
- No new planning docs — update `plans/apl-on-sx.md` inline.
|
||||
- Short, factual commit messages (`apl: outer product ∘. (+9)`).
|
||||
- One feature per iteration. Commit. Log. Next.
|
||||
|
||||
Go. Read the plan; find first `[ ]`; implement.
|
||||
80
plans/agent-briefings/common-lisp-loop.md
Normal file
80
plans/agent-briefings/common-lisp-loop.md
Normal file
@@ -0,0 +1,80 @@
|
||||
# common-lisp-on-sx loop agent (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/common-lisp-on-sx.md` forever. Conditions + restarts on delimited continuations is the headline showcase — every other Lisp reinvents resumable exceptions on the host stack. On SX `signal`/`invoke-restart` is just a captured continuation. Plus CLOS, the LOOP macro, packages.
|
||||
|
||||
```
|
||||
description: common-lisp-on-sx queue loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/common-lisp-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
1. Read `plans/common-lisp-on-sx.md` — roadmap + Progress log.
|
||||
2. `ls lib/common-lisp/` — pick up from the most advanced file.
|
||||
3. If `lib/common-lisp/tests/*.sx` exist, run them. Green before new work.
|
||||
4. If `lib/common-lisp/scoreboard.md` exists, that's your baseline.
|
||||
|
||||
## The queue
|
||||
|
||||
Phase order per `plans/common-lisp-on-sx.md`:
|
||||
|
||||
- **Phase 1** — reader + parser (read macros `#'` `'` `` ` `` `,` `,@` `#( … )` `#:` `#\char` `#xFF` `#b1010`, ratios, dispatch chars, lambda lists with `&optional`/`&rest`/`&key`/`&aux`)
|
||||
- **Phase 2** — sequential eval + special forms (`let`/`let*`/`flet`/`labels`, `block`/`return-from`, `tagbody`/`go`, `unwind-protect`, multiple values, `setf` subset, dynamic variables)
|
||||
- **Phase 3** — **THE SHOWCASE**: condition system + restarts. `define-condition`, `signal`/`error`/`cerror`/`warn`, `handler-bind` (non-unwinding), `handler-case` (unwinding), `restart-case`, `restart-bind`, `find-restart`/`invoke-restart`/`compute-restarts`, `with-condition-restarts`. Classic programs (restart-demo, parse-recover, interactive-debugger) green.
|
||||
- **Phase 4** — CLOS: `defclass`, `defgeneric`, `defmethod` with `:before`/`:after`/`:around`, `call-next-method`, multiple dispatch
|
||||
- **Phase 5** — macros + LOOP macro + reader macros
|
||||
- **Phase 6** — packages + stdlib (sequence functions, FORMAT directives, drive corpus to 200+)
|
||||
|
||||
Within a phase, pick the checkbox that unlocks the most tests per effort.
|
||||
|
||||
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Scope:** only `lib/common-lisp/**` and `plans/common-lisp-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. CL primitives go in `lib/common-lisp/runtime.sx`.
|
||||
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Worktree:** commit locally. Never push. Never touch `main`.
|
||||
- **Commit granularity:** one feature per commit.
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
|
||||
## Common-Lisp-specific gotchas
|
||||
|
||||
- **`handler-bind` is non-unwinding** — handlers can decline by returning normally, in which case `signal` keeps walking the chain. **`handler-case` is unwinding** — picking a handler aborts the protected form via a captured continuation. Don't conflate them.
|
||||
- **Restarts are not handlers.** `restart-case` establishes named *resumption points*; `signal` runs handler code with restarts visible; the handler chooses a restart by calling `invoke-restart`, which abandons handler stack and resumes at the restart point. Two stacks: handlers walk down, restarts wait to be invoked.
|
||||
- **`block` / `return-from`** is lexical. `block name … (return-from name v) …` captures `^k` once at entry; `return-from` invokes it. `return-from` to a name not in scope is an error (don't fall back to outer block).
|
||||
- **`tagbody` / `go`** — each tag in tagbody is a continuation; `go tag` invokes it. Tags are lexical, can only target tagbodies in scope.
|
||||
- **`unwind-protect`** runs cleanup on *any* non-local exit (return-from, throw, condition unwind). Implement as a scope frame fired by the cleanup machinery.
|
||||
- **Multiple values**: primary-value-only contexts (function args, `if` test, etc.) drop extras silently. `values` produces multiple. `multiple-value-bind` / `multiple-value-call` consume them. Don't auto-list.
|
||||
- **CLOS dispatch:** sort applicable methods by argument-list specificity (`subclassp` per arg, left-to-right); standard method combination calls primary methods most-specific-first via `call-next-method` chain. `:before` runs all before primaries; `:after` runs all after, in reverse-specificity. `:around` wraps everything.
|
||||
- **`call-next-method`** is a *continuation* available only inside a method body. Implement as a thunk stored in a dynamic-extent variable.
|
||||
- **Generalised reference (`setf`)**: `(setf (foo x) v)` ↦ `(setf-foo v x)`. Look up the setf-expander, not just a writer fn. `define-setf-expander` is mandatory for non-trivial places. Start with the symbolic / list / aref / slot-value cases.
|
||||
- **Dynamic variables (specials):** `defvar`/`defparameter` mark a symbol as special. `let` over a special name *rebinds* in dynamic extent (use parameterize-style scope), not lexical.
|
||||
- **Symbols are package-qualified.** Reader resolves `cl:car`, `mypkg::internal`, bare `foo` (current package). Internal vs external matters for `:` (one colon) reads.
|
||||
- **`nil` is also `()` is also the empty list.** Same object. `nil` is also false. CL has no distinct unit value.
|
||||
- **LOOP macro is huge.** Build incrementally — start with `for/in`, `for/from`, `collect`, `sum`, `count`, `repeat`. Add conditional clauses (`when`, `if`, `else`) once iteration drivers stable. `named` blocks + `return-from named` last.
|
||||
- **Test corpus:** custom + curated `ansi-test` slice. Place programs in `lib/common-lisp/tests/programs/` with `.lisp` extension.
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` clauses evaluate only the last expr.
|
||||
- `type-of` on user fn returns `"lambda"`.
|
||||
- Shell heredoc `||` gets eaten — escape or use `case`.
|
||||
|
||||
## Style
|
||||
|
||||
- No comments in `.sx` unless non-obvious.
|
||||
- No new planning docs — update `plans/common-lisp-on-sx.md` inline.
|
||||
- Short, factual commit messages (`common-lisp: handler-bind + 12 tests`).
|
||||
- One feature per iteration. Commit. Log. Next.
|
||||
|
||||
Go. Read the plan; find first `[ ]`; implement.
|
||||
83
plans/agent-briefings/ruby-loop.md
Normal file
83
plans/agent-briefings/ruby-loop.md
Normal file
@@ -0,0 +1,83 @@
|
||||
# ruby-on-sx loop agent (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/ruby-on-sx.md` forever. Fibers via delcc is the headline showcase — `Fiber.new`/`Fiber.yield`/`Fiber.resume` are textbook delimited continuations with sugar, where MRI does it via C-stack swapping. Plus blocks/yield (lexical escape continuations, same shape as Smalltalk's non-local return), method_missing, and singleton classes.
|
||||
|
||||
```
|
||||
description: ruby-on-sx queue loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/ruby-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
1. Read `plans/ruby-on-sx.md` — roadmap + Progress log.
|
||||
2. `ls lib/ruby/` — pick up from the most advanced file.
|
||||
3. If `lib/ruby/tests/*.sx` exist, run them. Green before new work.
|
||||
4. If `lib/ruby/scoreboard.md` exists, that's your baseline.
|
||||
|
||||
## The queue
|
||||
|
||||
Phase order per `plans/ruby-on-sx.md`:
|
||||
|
||||
- **Phase 1** — tokenizer + parser. Keywords, identifier sigils (`@` ivar, `@@` cvar, `$` global), strings with interpolation, `%w[]`/`%i[]`, symbols, blocks `{|x| …}` and `do |x| … end`, splats, default args, method def
|
||||
- **Phase 2** — object model + sequential eval. Class table, ancestor-chain dispatch, `super`, singleton classes, `method_missing` fallback, dynamic constant lookup
|
||||
- **Phase 3** — blocks + procs + lambdas. Method captures escape continuation `^k`; `yield` / `return` / `break` / `next` / `redo` semantics; lambda strict arity vs proc lax
|
||||
- **Phase 4** — **THE SHOWCASE**: fibers via delcc. `Fiber.new`/`Fiber.resume`/`Fiber.yield`/`Fiber.transfer`. Classic programs (generator, producer-consumer, tree-walk) green
|
||||
- **Phase 5** — modules + mixins + metaprogramming. `include`/`prepend`/`extend`, `define_method`, `class_eval`/`instance_eval`, `respond_to?`/`respond_to_missing?`, hooks
|
||||
- **Phase 6** — stdlib drive. `Enumerable` mixin, `Comparable`, Array/Hash/Range/String/Integer methods, drive corpus to 200+
|
||||
|
||||
Within a phase, pick the checkbox that unlocks the most tests per effort.
|
||||
|
||||
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Scope:** only `lib/ruby/**` and `plans/ruby-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. Ruby primitives go in `lib/ruby/runtime.sx`.
|
||||
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Worktree:** commit locally. Never push. Never touch `main`.
|
||||
- **Commit granularity:** one feature per commit.
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
|
||||
## Ruby-specific gotchas
|
||||
|
||||
- **Block `return` vs lambda `return`.** Inside a block `{ ... return v }`, `return` invokes the *enclosing method's* escape continuation (non-local return). Inside a lambda `->(){ ... return v }`, `return` returns from the *lambda*. Don't conflate. Implement: blocks bind their `^method-k`; lambdas bind their own `^lambda-k`.
|
||||
- **`break` from inside a block** invokes a different escape — the *iteration loop's* escape — and the loop returns the break-value. `next` is escape from current iteration, returns iteration value. `redo` re-enters current iteration without advancing.
|
||||
- **Proc arity is lax.** `proc { |a, b, c| … }.call(1, 2)` ↦ `c = nil`. Lambda is strict — same call raises ArgumentError. Check arity at call site for lambdas only.
|
||||
- **Block argument unpacking.** `[[1,2],[3,4]].each { |a, b| … }` — single Array arg auto-unpacks for blocks (not lambdas). One arg, one Array → unpack. Frequent footgun.
|
||||
- **Method dispatch chain order:** prepended modules → class methods → included modules → superclass → BasicObject → method_missing. `super` walks from the *defining* class's position, not the receiver class's.
|
||||
- **Singleton classes** are lazily allocated. Looking up the chain for an object passes through its singleton class first, then its actual class. `class << obj; …; end` opens the singleton.
|
||||
- **`method_missing`** — fallback when ancestor walk misses. Receives `(name_symbol, *args, &blk)`. Pair with `respond_to_missing?` for `respond_to?` to also report true. Do **not** swallow NoMethodError silently.
|
||||
- **Ivars are per-object dicts.** Reading an unset ivar yields `nil` and a warning (`-W`). Don't error.
|
||||
- **Constant lookup** is first lexical (Module.nesting), then inheritance (Module.ancestors of the innermost class). Different from method lookup.
|
||||
- **`Object#send`** invokes private and public methods alike; `Object#public_send` skips privates.
|
||||
- **Class reopening.** `class Foo; def bar; …; end; end` plus a later `class Foo; def baz; …; end; end` adds methods to the same class. Class table lookups must be by-name, mutable; methods dict is mutable.
|
||||
- **Fiber semantics.** `Fiber.new { |arg| … }` creates a fiber suspended at entry. First `Fiber.resume(v)` enters with `arg = v`. Inside, `Fiber.yield(w)` returns `w` to the resumer; the next `Fiber.resume(v')` returns `v'` to the yield site. End of block returns final value to last resumer; subsequent `Fiber.resume` raises FiberError.
|
||||
- **`Fiber.transfer`** is symmetric — either side can transfer to the other; no resume/yield asymmetry. Implement on top of the same continuation pair, just don't enforce direction.
|
||||
- **Symbols are interned.** `:foo == :foo` is identity. Use SX symbols.
|
||||
- **Strings are mutable.** `s = "abc"; s << "d"; s == "abcd"`. Hash keys can be strings; hash dups string keys at insertion to be safe (or freeze them).
|
||||
- **Truthiness:** only `false` and `nil` are falsy. `0`, `""`, `[]` are truthy.
|
||||
- **Test corpus:** custom + curated RubySpec slice. Place programs in `lib/ruby/tests/programs/` with `.rb` extension.
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` clauses evaluate only the last expr.
|
||||
- `type-of` on user fn returns `"lambda"`.
|
||||
- Shell heredoc `||` gets eaten — escape or use `case`.
|
||||
|
||||
## Style
|
||||
|
||||
- No comments in `.sx` unless non-obvious.
|
||||
- No new planning docs — update `plans/ruby-on-sx.md` inline.
|
||||
- Short, factual commit messages (`ruby: Fiber.yield + Fiber.resume (+8)`).
|
||||
- One feature per iteration. Commit. Log. Next.
|
||||
|
||||
Go. Read the plan; find first `[ ]`; implement.
|
||||
83
plans/agent-briefings/tcl-loop.md
Normal file
83
plans/agent-briefings/tcl-loop.md
Normal file
@@ -0,0 +1,83 @@
|
||||
# tcl-on-sx loop agent (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/tcl-on-sx.md` forever. `uplevel`/`upvar` is the headline showcase — Tcl's superpower for defining your own control structures, requiring deep VM cooperation in any normal host but falling out of SX's first-class env-chain. Plus the Dodekalogue (12 rules), command-substitution everywhere, and "everything is a string" homoiconicity.
|
||||
|
||||
```
|
||||
description: tcl-on-sx queue loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/tcl-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
1. Read `plans/tcl-on-sx.md` — roadmap + Progress log.
|
||||
2. `ls lib/tcl/` — pick up from the most advanced file.
|
||||
3. If `lib/tcl/tests/*.sx` exist, run them. Green before new work.
|
||||
4. If `lib/tcl/scoreboard.md` exists, that's your baseline.
|
||||
|
||||
## The queue
|
||||
|
||||
Phase order per `plans/tcl-on-sx.md`:
|
||||
|
||||
- **Phase 1** — tokenizer + parser. The Dodekalogue (12 rules): word-splitting, command sub `[…]`, var sub `$name`/`${name}`/`$arr(idx)`, double-quote vs brace word, backslash, `;`, `#` comments only at command start, single-pass left-to-right substitution
|
||||
- **Phase 2** — sequential eval + core commands. `set`/`unset`/`incr`/`append`/`lappend`, `puts`/`gets`, `expr` (own mini-language), `if`/`while`/`for`/`foreach`/`switch`, string commands, list commands, dict commands
|
||||
- **Phase 3** — **THE SHOWCASE**: `proc` + `uplevel` + `upvar`. Frame stack with proc-call push/pop; `uplevel #N script` evaluates in caller's frame; `upvar` aliases names across frames. Classic programs (for-each-line, assert macro, with-temp-var) green
|
||||
- **Phase 4** — `return -code N`, `catch`, `try`/`trap`/`finally`, `throw`. Control flow as integer codes
|
||||
- **Phase 5** — namespaces + ensembles. `namespace eval`, qualified names `::ns::cmd`, ensembles, `namespace path`
|
||||
- **Phase 6** — coroutines (built on fibers, same delcc as Ruby fibers) + system commands + drive corpus to 150+
|
||||
|
||||
Within a phase, pick the checkbox that unlocks the most tests per effort.
|
||||
|
||||
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Scope:** only `lib/tcl/**` and `plans/tcl-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. Tcl primitives go in `lib/tcl/runtime.sx`.
|
||||
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Worktree:** commit locally. Never push. Never touch `main`.
|
||||
- **Commit granularity:** one feature per commit.
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
|
||||
## Tcl-specific gotchas
|
||||
|
||||
- **Everything is a string.** Internally cache shimmer reps (list, dict, int, double) for performance, but every value must be re-stringifiable. Mutating one rep dirties the cached string and vice versa.
|
||||
- **The Dodekalogue is strict.** Substitution is **one-pass**, **left-to-right**. The result of a substitution is a value, not a script — it does NOT get re-parsed for further substitutions. This is what makes Tcl safe-by-default. Don't accidentally re-parse.
|
||||
- **Brace word `{…}`** is the only way to defer evaluation. No substitution inside, just balanced braces. Used for `if {expr}` body, `proc body`, `expr` arguments.
|
||||
- **Double-quote word `"…"`** is identical to a bare word for substitution purposes — it just allows whitespace in a single word. `\` escapes still apply.
|
||||
- **Comments are only at command position.** `# this is a comment` after a `;` or newline; *not* inside a command. `set x 1 # not a comment` is a 4-arg `set`.
|
||||
- **`expr` has its own grammar** — operator precedence, function calls — and does its own substitution. Brace `expr {$x + 1}` to avoid double-substitution and to enable bytecode caching.
|
||||
- **`if` and `while` re-parse** the condition only if not braced. Always use `if {…}`/`while {…}` form. The unbraced form re-substitutes per iteration.
|
||||
- **`return` from a `proc`** uses control code 2. `break` is 3, `continue` is 4. `error` is 1. `catch` traps any non-zero code; user can return non-zero with `return -code error -errorcode FOO message`.
|
||||
- **`uplevel #0 script`** is global frame. `uplevel 1 script` (or just `uplevel script`) is caller's frame. `uplevel #N` is absolute level N (0=global, 1=top-level proc, 2=proc-called-from-top, …). Negative levels are errors.
|
||||
- **`upvar #N otherVar localVar`** binds `localVar` in the current frame as an *alias* — both names refer to the same storage. Reads and writes go through the alias.
|
||||
- **`info level`** with no arg returns current level number. `info level N` (positive) returns the command list that invoked level N. `info level -N` returns the command list of the level N relative-up.
|
||||
- **Variable names with `(…)`** are array elements: `set arr(foo) 1`. Arrays are not first-class values — you can't `set x $arr`. `array get arr` gives a flat list `{key1 val1 key2 val2 …}`.
|
||||
- **List vs string.** `set l "a b c"` and `set l [list a b c]` look the same when printed but the second has a cached list rep. `lindex` works on both via shimmering. Most user code can't tell the difference.
|
||||
- **`incr x`** errors if x doesn't exist; pre-set with `set x 0` or use `incr x 0` first if you mean "create-or-increment". Or use `dict incr` for dicts.
|
||||
- **Coroutines are fibers.** `coroutine name body` starts a coroutine; calling `name` resumes it; `yield value` from inside suspends and returns `value` to the resumer. Same primitive as Ruby fibers — share the implementation under the hood.
|
||||
- **`switch`** matches first clause whose pattern matches. Default is `default`. Variant matches: glob (default), `-exact`, `-glob`, `-regexp`. Body `-` means "fall through to next clause's body".
|
||||
- **Test corpus:** custom + slice of Tcl's own tests. Place programs in `lib/tcl/tests/programs/` with `.tcl` extension.
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` clauses evaluate only the last expr.
|
||||
- `type-of` on user fn returns `"lambda"`.
|
||||
- Shell heredoc `||` gets eaten — escape or use `case`.
|
||||
|
||||
## Style
|
||||
|
||||
- No comments in `.sx` unless non-obvious.
|
||||
- No new planning docs — update `plans/tcl-on-sx.md` inline.
|
||||
- Short, factual commit messages (`tcl: uplevel + upvar (+11)`).
|
||||
- One feature per iteration. Commit. Log. Next.
|
||||
|
||||
Go. Read the plan; find first `[ ]`; implement.
|
||||
115
plans/apl-on-sx.md
Normal file
115
plans/apl-on-sx.md
Normal file
@@ -0,0 +1,115 @@
|
||||
# APL-on-SX: rank-polymorphic primitives + glyph parser
|
||||
|
||||
The headline showcase is **rank polymorphism** — a single primitive (`+`, `⌈`, `⊂`, `⍳`) works uniformly on scalars, vectors, matrices, and higher-rank arrays. ~80 glyph primitives + 6 operators bind together with right-to-left evaluation; the entire language is a high-density combinator algebra. The JIT compiler + primitive table pay off massively here because almost every program is `array → array` pure pipelines.
|
||||
|
||||
End-state goal: Dyalog-flavoured APL subset, dfns + tradfns, classic programs (game-of-life, mandelbrot, prime-sieve, n-queens, conway), 100+ green tests.
|
||||
|
||||
## Scope decisions (defaults — override by editing before we spawn)
|
||||
|
||||
- **Syntax:** Dyalog APL surface, Unicode glyphs. `⎕`-quad system functions for I/O. `∇` tradfn header.
|
||||
- **Conformance:** "Reads like APL, runs like APL." Not byte-compat with Dyalog; we care about right-to-left semantics and rank polymorphism.
|
||||
- **Test corpus:** custom — APL idioms (Roger Hui style), classic programs, plus ~50 pattern tests for primitives.
|
||||
- **Out of scope:** ⎕-namespaces beyond a handful, complex numbers, full TAO ordering, `⎕FX` runtime function definition (use static `∇` only), nested-array-of-functions higher orders, the editor.
|
||||
- **Glyphs:** input via plain Unicode in `.apl` source files. Backtick-prefix shortcuts handled by the user's editor — we don't ship one.
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/apl/**` and `plans/apl-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. APL primitives go in `lib/apl/runtime.sx`.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
APL source (Unicode glyphs)
|
||||
│
|
||||
▼
|
||||
lib/apl/tokenizer.sx — glyphs, identifiers, numbers (¯ for negative), strings, strands
|
||||
│
|
||||
▼
|
||||
lib/apl/parser.sx — right-to-left with valence resolution (mon vs dyadic by position)
|
||||
│
|
||||
▼
|
||||
lib/apl/transpile.sx — AST → SX AST (entry: apl-eval-ast)
|
||||
│
|
||||
▼
|
||||
lib/apl/runtime.sx — array model, ~80 primitives, 6 operators, dfns/tradfns
|
||||
```
|
||||
|
||||
Core mapping:
|
||||
- **Array** = SX dict `{:shape (d1 d2 …) :ravel #(v1 v2 …)}`. Scalar is rank-0 (empty shape), vector is rank-1, matrix rank-2, etc. Type uniformity not required (heterogeneous nested arrays via "boxed" elements `⊂x`).
|
||||
- **Rank polymorphism** — every scalar primitive is broadcast: `1 2 3 + 4 5 6` ↦ `5 7 9`; `(2 3⍴⍳6) + 1` ↦ broadcast scalar to matrix.
|
||||
- **Conformability** = matching shapes, or one-side scalar, or rank-1 cycling (deferred — keep strict in v1).
|
||||
- **Valence** = each glyph has a monadic and a dyadic meaning; resolution is purely positional (left-arg present → dyadic).
|
||||
- **Operator** = takes one or two function operands, returns a derived function (`f¨` = `each f`, `f/` = `reduce f`, `f∘g` = `compose`, `f⍨` = `commute`).
|
||||
- **Tradfn** `∇R←L F R; locals` = named function with explicit header.
|
||||
- **Dfn** `{⍺+⍵}` = anonymous, `⍺` = left arg, `⍵` = right arg, `∇` = recurse.
|
||||
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — tokenizer + parser
|
||||
- [ ] Tokenizer: Unicode glyphs (the full APL set: `+ - × ÷ * ⍟ ⌈ ⌊ | ! ? ○ ~ < ≤ = ≥ > ≠ ∊ ∧ ∨ ⍱ ⍲ , ⍪ ⍴ ⌽ ⊖ ⍉ ↑ ↓ ⊂ ⊃ ⊆ ∪ ∩ ⍳ ⍸ ⌷ ⍋ ⍒ ⊥ ⊤ ⊣ ⊢ ⍎ ⍕ ⍝`), operators (`/ \ ¨ ⍨ ∘ . ⍣ ⍤ ⍥ @`), numbers (`¯` for negative, `1E2`, `1J2` complex deferred), characters (`'a'`, `''` escape), strands (juxtaposition of literals: `1 2 3`), names, comments `⍝ …`
|
||||
- [ ] Parser: right-to-left; classify each token as function, operator, value, or name; resolve valence positionally; dfn `{…}` body, tradfn `∇` header, guards `:`, control words `:If :While :For …` (Dyalog-style)
|
||||
- [ ] Unit tests in `lib/apl/tests/parse.sx`
|
||||
|
||||
### Phase 2 — array model + scalar primitives
|
||||
- [ ] Array constructor: `make-array shape ravel`, `scalar v`, `vector v…`, `enclose`/`disclose`
|
||||
- [ ] Shape arithmetic: `⍴` (shape), `,` (ravel), `≢` (tally / first-axis-length), `≡` (depth)
|
||||
- [ ] Scalar arithmetic primitives broadcast: `+ - × ÷ ⌈ ⌊ * ⍟ | ! ○`
|
||||
- [ ] Scalar comparison primitives: `< ≤ = ≥ > ≠`
|
||||
- [ ] Scalar logical: `~ ∧ ∨ ⍱ ⍲`
|
||||
- [ ] Index generator: `⍳n` (vector 1..n or 0..n-1 depending on `⎕IO`)
|
||||
- [ ] `⎕IO` = 1 default (Dyalog convention)
|
||||
- [ ] 40+ tests in `lib/apl/tests/scalar.sx`
|
||||
|
||||
### Phase 3 — structural primitives + indexing
|
||||
- [ ] Reshape `⍴`, ravel `,`, transpose `⍉` (full + dyadic axis spec)
|
||||
- [ ] Take `↑`, drop `↓`, rotate `⌽` (last axis), `⊖` (first axis)
|
||||
- [ ] Catenate `,` (last axis) and `⍪` (first axis)
|
||||
- [ ] Index `⌷` (squad), bracket-indexing `A[I]` (sugar for `⌷`)
|
||||
- [ ] Grade-up `⍋`, grade-down `⍒`
|
||||
- [ ] Enclose `⊂`, disclose `⊃`, partition (subset deferred)
|
||||
- [ ] Membership `∊`, find `⍳` (dyadic), without `~` (dyadic), unique `∪` (deferred to phase 6)
|
||||
- [ ] 40+ tests in `lib/apl/tests/structural.sx`
|
||||
|
||||
### Phase 4 — operators (THE SHOWCASE)
|
||||
- [ ] Reduce `f/` (last axis), `f⌿` (first axis) — including `∧/`, `∨/`, `+/`, `×/`, `⌈/`, `⌊/`
|
||||
- [ ] Scan `f\`, `f⍀`
|
||||
- [ ] Each `f¨` — applies `f` to each scalar/element
|
||||
- [ ] Outer product `∘.f` — `1 2 3 ∘.× 1 2 3` ↦ multiplication table
|
||||
- [ ] Inner product `f.g` — `+.×` is matrix multiply
|
||||
- [ ] Commute `f⍨` — `f⍨ x` ↔ `x f x`, `x f⍨ y` ↔ `y f x`
|
||||
- [ ] Compose `f∘g` — applies `g` first then `f`
|
||||
- [ ] Power `f⍣n` — apply f n times; `f⍣≡` until fixed point
|
||||
- [ ] Rank `f⍤k` — apply f at sub-rank k
|
||||
- [ ] At `@` — selective replace
|
||||
- [ ] 40+ tests in `lib/apl/tests/operators.sx`
|
||||
|
||||
### Phase 5 — dfns + tradfns + control flow
|
||||
- [ ] Dfn `{…}` with `⍺` (left arg, may be absent → niladic/monadic), `⍵` (right arg), `∇` (recurse), guards `cond:expr`, default left arg `⍺←default`
|
||||
- [ ] Local assignment via `←` (lexical inside dfn)
|
||||
- [ ] Tradfn `∇` header: `R←L F R;l1;l2`, statement-by-statement, branch via `→linenum`
|
||||
- [ ] Dyalog control words: `:If/:Else/:EndIf`, `:While/:EndWhile`, `:For X :In V :EndFor`, `:Select/:Case/:EndSelect`, `:Trap`/`:EndTrap`
|
||||
- [ ] Niladic / monadic / dyadic dispatch (function valence at definition time)
|
||||
- [ ] `lib/apl/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
||||
|
||||
### Phase 6 — classic programs + drive corpus
|
||||
- [ ] Classic programs in `lib/apl/tests/programs/`:
|
||||
- [ ] `life.apl` — Conway's Game of Life as a one-liner using `⊂` `⊖` `⌽` `+/`
|
||||
- [ ] `mandelbrot.apl` — complex iteration with rank-polymorphic `+ × ⌊` (or real-axis subset)
|
||||
- [ ] `primes.apl` — `(2=+⌿0=A∘.|A)/A←⍳N` sieve
|
||||
- [ ] `n-queens.apl` — backtracking via reduce
|
||||
- [ ] `quicksort.apl` — the classic Roger Hui one-liner
|
||||
- [ ] System functions: `⎕FMT`, `⎕FR` (float repr), `⎕TS` (timestamp), `⎕IO`, `⎕ML` (migration level — fixed at 1), `⎕←` (print)
|
||||
- [ ] Drive corpus to 100+ green
|
||||
- [ ] Idiom corpus — `lib/apl/tests/idioms.sx` covering classic Roger Hui / Phil Last idioms
|
||||
|
||||
## Progress log
|
||||
|
||||
_Newest first._
|
||||
|
||||
- _(none yet)_
|
||||
|
||||
## Blockers
|
||||
|
||||
- _(none yet)_
|
||||
121
plans/common-lisp-on-sx.md
Normal file
121
plans/common-lisp-on-sx.md
Normal file
@@ -0,0 +1,121 @@
|
||||
# Common-Lisp-on-SX: conditions + restarts on delimited continuations
|
||||
|
||||
The headline showcase is the **condition system**. Restarts are *resumable* exceptions — every other Lisp implementation reinvents this on host-stack unwind tricks. On SX restarts are textbook delimited continuations: `signal` walks the handler chain; `invoke-restart` resumes the captured continuation at the restart point. Same delcc primitive that powers Erlang actors, expressed as a different surface.
|
||||
|
||||
End-state goal: ANSI Common Lisp subset with a working condition/restart system, CLOS multimethods (with `:before`/`:after`/`:around`), the LOOP macro, packages, and ~150 hand-written + classic programs.
|
||||
|
||||
## Scope decisions (defaults — override by editing before we spawn)
|
||||
|
||||
- **Syntax:** ANSI Common Lisp surface. Read tables, dispatch macros (`#'`, `#(`, `#\`, `#:`, `#x`, `#b`, `#o`, ratios `1/3`).
|
||||
- **Conformance:** ANSI X3.226 *as a target*, not bug-for-bug SBCL/CCL. "Reads like CL, runs like CL."
|
||||
- **Test corpus:** custom + a curated slice of `ansi-test`. Plus classic programs: condition-system demo, restart-driven debugger, multiple-dispatch geometry, LOOP corpus.
|
||||
- **Out of scope:** compilation to native, FFI, sockets, threads, MOP class redefinition, full pathname/logical-pathname machinery, structures with `:include` deep customization.
|
||||
- **Packages:** simple — `defpackage`/`in-package`/`export`/`use-package`/`:cl`/`:cl-user`. No nicknames, no shadowing-import edge cases.
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/common-lisp/**` and `plans/common-lisp-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. CL primitives go in `lib/common-lisp/runtime.sx`.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
Common Lisp source
|
||||
│
|
||||
▼
|
||||
lib/common-lisp/reader.sx — tokenizer + reader (read macros, dispatch chars)
|
||||
│
|
||||
▼
|
||||
lib/common-lisp/parser.sx — AST: forms, declarations, lambda lists
|
||||
│
|
||||
▼
|
||||
lib/common-lisp/transpile.sx — AST → SX AST (entry: cl-eval-ast)
|
||||
│
|
||||
▼
|
||||
lib/common-lisp/runtime.sx — special forms, condition system, CLOS, packages, BIFs
|
||||
```
|
||||
|
||||
Core mapping:
|
||||
- **Symbol** = SX symbol with package prefix; package table is a flat dict.
|
||||
- **Cons cell** = SX pair via `cons`/`car`/`cdr`; lists native.
|
||||
- **Multiple values** = thread through `values`/`multiple-value-bind`; primary-value default for one-context callers.
|
||||
- **Block / return-from** = captured continuation; `return-from name v` invokes the block-named `^k`.
|
||||
- **Tagbody / go** = each tag is a continuation; `go tag` invokes it.
|
||||
- **Unwind-protect** = scope frame with a cleanup thunk fired on any non-local exit.
|
||||
- **Conditions / restarts** = layered handler chain on top of `handler-bind` + delcc. `signal` walks handlers; `invoke-restart` resumes a captured continuation.
|
||||
- **CLOS** = generic functions are dispatch tables on argument-class lists; method combination computed lazily; `call-next-method` is a continuation.
|
||||
- **Macros** = SX macros (sentinel-body) — defmacro lowers directly.
|
||||
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — reader + parser
|
||||
- [ ] Tokenizer: symbols (with package qualification `pkg:sym` / `pkg::sym`), numbers (int, float, ratio `1/3`, `#xFF`, `#b1010`, `#o17`), strings `"…"` with `\` escapes, characters `#\Space` `#\Newline` `#\a`, comments `;`, block comments `#| … |#`
|
||||
- [ ] Reader: list, dotted pair, quote `'`, function `#'`, quasiquote `` ` ``, unquote `,`, splice `,@`, vector `#(…)`, uninterned `#:foo`, nil/t literals
|
||||
- [ ] Parser: lambda lists with `&optional` `&rest` `&key` `&aux` `&allow-other-keys`, defaults, supplied-p variables
|
||||
- [ ] Unit tests in `lib/common-lisp/tests/read.sx`
|
||||
|
||||
### Phase 2 — sequential eval + special forms
|
||||
- [ ] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when`
|
||||
- [ ] `block` + `return-from` via captured continuation
|
||||
- [ ] `tagbody` + `go` via per-tag continuations
|
||||
- [ ] `unwind-protect` cleanup frame
|
||||
- [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
|
||||
- [ ] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
|
||||
- [ ] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope
|
||||
- [ ] 60+ tests in `lib/common-lisp/tests/eval.sx`
|
||||
|
||||
### Phase 3 — conditions + restarts (THE SHOWCASE)
|
||||
- [ ] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero`
|
||||
- [ ] `signal`, `error`, `cerror`, `warn` — all walk the handler chain
|
||||
- [ ] `handler-bind` — non-unwinding handlers, may decline by returning normally
|
||||
- [ ] `handler-case` — unwinding handlers (delcc abort)
|
||||
- [ ] `restart-case`, `with-simple-restart`, `restart-bind`
|
||||
- [ ] `find-restart`, `invoke-restart`, `invoke-restart-interactively`, `compute-restarts`
|
||||
- [ ] `with-condition-restarts` — associate restarts with a specific condition
|
||||
- [ ] `*break-on-signals*`, `*debugger-hook*` (basic)
|
||||
- [ ] Classic programs in `lib/common-lisp/tests/programs/`:
|
||||
- [ ] `restart-demo.lisp` — division with `:use-zero` and `:retry` restarts
|
||||
- [ ] `parse-recover.lisp` — parser with skipped-token restart
|
||||
- [ ] `interactive-debugger.lisp` — ASCII REPL using `:debugger-hook`
|
||||
- [ ] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
||||
|
||||
### Phase 4 — CLOS
|
||||
- [ ] `defclass` with `:initarg`/`:initform`/`:accessor`/`:reader`/`:writer`/`:allocation`
|
||||
- [ ] `make-instance`, `slot-value`, `(setf slot-value)`, `with-slots`, `with-accessors`
|
||||
- [ ] `defgeneric` with `:method-combination` (standard, plus `+`, `and`, `or`)
|
||||
- [ ] `defmethod` with `:before` / `:after` / `:around` qualifiers
|
||||
- [ ] `call-next-method` (continuation), `next-method-p`
|
||||
- [ ] `class-of`, `find-class`, `slot-boundp`, `change-class` (basic)
|
||||
- [ ] Multiple dispatch — method specificity by argument-class precedence list
|
||||
- [ ] Built-in classes registered for tagged values (`integer`, `float`, `string`, `symbol`, `cons`, `null`, `t`)
|
||||
- [ ] Classic programs:
|
||||
- [ ] `geometry.lisp` — `intersect` generic dispatching on (point line), (line line), (line plane)…
|
||||
- [ ] `mop-trace.lisp` — `:before` + `:after` printing call trace
|
||||
|
||||
### Phase 5 — macros + LOOP + reader macros
|
||||
- [ ] `defmacro`, `macrolet`, `symbol-macrolet`, `macroexpand-1`, `macroexpand`
|
||||
- [ ] `gensym`, `gentemp`
|
||||
- [ ] `set-macro-character`, `set-dispatch-macro-character`, `get-macro-character`
|
||||
- [ ] **The LOOP macro** — iteration drivers (`for … in/across/from/upto/downto/by`, `while`, `until`, `repeat`), accumulators (`collect`, `append`, `nconc`, `count`, `sum`, `maximize`, `minimize`), conditional clauses (`if`/`when`/`unless`/`else`), termination (`finally`/`thereis`/`always`/`never`), `named` blocks
|
||||
- [ ] LOOP test corpus: 30+ tests covering all clause types
|
||||
|
||||
### Phase 6 — packages + stdlib drive
|
||||
- [ ] `defpackage`, `in-package`, `export`, `use-package`, `import`, `find-package`
|
||||
- [ ] Package qualification at the reader level — `cl:car`, `mypkg::internal`
|
||||
- [ ] `:common-lisp` (`:cl`) and `:common-lisp-user` (`:cl-user`) packages
|
||||
- [ ] Sequence functions — `mapcar`, `mapc`, `mapcan`, `reduce`, `find`, `find-if`, `position`, `count`, `every`, `some`, `notany`, `notevery`, `remove`, `remove-if`, `subst`
|
||||
- [ ] List ops — `assoc`, `getf`, `nth`, `last`, `butlast`, `nthcdr`, `tailp`, `ldiff`
|
||||
- [ ] String ops — `string=`, `string-upcase`, `string-downcase`, `subseq`, `concatenate`
|
||||
- [ ] FORMAT — basic directives `~A`, `~S`, `~D`, `~F`, `~%`, `~&`, `~T`, `~{...~}` (iteration), `~[...~]` (conditional), `~^` (escape), `~P` (plural)
|
||||
- [ ] Drive corpus to 200+ green
|
||||
|
||||
## Progress log
|
||||
|
||||
_Newest first._
|
||||
|
||||
- _(none yet)_
|
||||
|
||||
## Blockers
|
||||
|
||||
- _(none yet)_
|
||||
96
plans/hs-blockers-drain.md
Normal file
96
plans/hs-blockers-drain.md
Normal file
@@ -0,0 +1,96 @@
|
||||
# HS conformance — blockers drain
|
||||
|
||||
Goal: take hyperscript conformance from **1277/1496 (85.4%)** to **1496/1496 (100%)** by clearing the blocked clusters and the design-done Bucket E subsystems.
|
||||
|
||||
This plan exists because the per-iteration `loops/hs` agent can't fit these into its 30-min budget — they need dedicated multi-commit sit-downs. Track progress here; refer to `plans/hs-conformance-to-100.md` for the canonical cluster ledger.
|
||||
|
||||
## Current state (2026-04-25)
|
||||
|
||||
- Loop running in `/root/rose-ash-loops/hs` (branch `loops/hs`)
|
||||
- sx-tree MCP **fixed** (was a session-stale binary issue — restart of claude in the tmux window picked it up). Loop hinted to retry **#32**, **#29** first.
|
||||
- Recent loop progress: ~1 commit/6h — easy wins drained, what's left needs focused attention.
|
||||
|
||||
## Remaining work
|
||||
|
||||
### Bucket-A/B/C blockers (small, in-place fixes)
|
||||
|
||||
| # | Cluster | Tests | Effort | Blocker | Fix sketch |
|
||||
|---|---------|------:|--------|---------|------------|
|
||||
| **17** | `tell` semantics | +3 | ~1h | Implicit-default-target ambiguity. `bare add .bar` inside `tell X` should target `X` but explicit `to me` must reach the original element. | Add `beingTold` symbol distinct from `me`; bare commands compile to `beingTold-or-me`; explicit `me` always the original. |
|
||||
| **22** | window global fn fallback | +2-4 | ~1h | `foo()` where `foo` isn't SX-defined needs to fall back to `(host-global "foo")`. Three attempts failed: guard (host-level error not catchable), `env-has?` (not in HS kernel), `hs-win-call` (NativeFn not callable from CALL). | Add `symbol-bound?` predicate to HS kernel **OR** a host-call-fn primitive with arity-agnostic dispatch. |
|
||||
| **29** | `hyperscript:before:init` / `:after:init` / `:parse-error` events | +4-6 | ~30m (post sx-tree fix) | Was sx-tree MCP outage. Now unblocked — loop should retry. 4 of 6 tests need stricter parser error-rejection (out of scope; mark partial). | Edit `integration.sx` to fire DOM events at activation boundaries. |
|
||||
|
||||
### Bucket D — medium features
|
||||
|
||||
| # | Cluster | Tests | Effort | Status |
|
||||
|---|---------|------:|--------|--------|
|
||||
| **31** | runtime null-safety error reporting | **+15-18** | **2-4h** | **THIS SESSION'S TARGET.** Plan node fully spec'd: 5 pieces of work. |
|
||||
| **32** | MutationObserver mock + `on mutation` | +10-15 | ~2h | Was sx-tree-blocked. Now unblocked — loop hinted to retry. Multi-file: parser, compiler, runtime, runner mock, generator skip-list. |
|
||||
| **33** | cookie API | +2 (remaining) | ~30m | Partial done (+3). Remaining 2 need `hs-method-call` runtime fallback for unknown methods + `hs-for-each` recognising host-array/proxy collections. |
|
||||
| 34 | event modifier DSL | +6-8 | ~1-2h | `elsewhere`, `every`, count filters (`once`/`twice`/`3 times`/ranges), `from elsewhere`. Pending. |
|
||||
| 35 | namespaced `def` | +3 | ~30m | Pending. |
|
||||
|
||||
### Bucket E — subsystems (design docs landed, multi-commit each)
|
||||
|
||||
Each has a design doc with a step-by-step checklist. These are 1-2 days of focused work each, not loop-fits.
|
||||
|
||||
| # | Subsystem | Tests | Design doc | Branch |
|
||||
|---|-----------|------:|------------|--------|
|
||||
| 36 | WebSocket + `socket` + RPC Proxy | +12-16 | `plans/designs/e36-websocket.md` | `worktree-agent-a9daf73703f520257` |
|
||||
| 37 | Tokenizer-as-API | +16-17 | `plans/designs/e37-tokenizer-api.md` | `worktree-agent-a6bb61d59cc0be8b4` |
|
||||
| 38 | SourceInfo API | +4 | `plans/designs/e38-sourceinfo.md` | `agent-e38-sourceinfo` |
|
||||
| 39 | WebWorker plugin (parser-only stub) | +1 | `plans/designs/e39-webworker.md` | `hs-design-e39-webworker` |
|
||||
| 40 | Real Fetch / non-2xx / before-fetch | +7 | `plans/designs/e40-real-fetch.md` | `worktree-agent-a94612a4283eaa5e0` |
|
||||
|
||||
### Bucket F — generator translation gaps
|
||||
|
||||
~25 tests SKIP'd because `tests/playwright/generate-sx-tests.py` bails with `return None`. Single dedicated generator-repair sit-down once Bucket D is drained. ~half-day.
|
||||
|
||||
## Order of attack
|
||||
|
||||
In approximate cost-per-test order:
|
||||
|
||||
1. **Loop self-heal** (no human work) — wait for #29, #32 to land via the running loop ⏱️ ~next 1-2 hours
|
||||
2. **#31 null-safety** — biggest scoped single win, dedicated worktree agent (this session)
|
||||
3. **#33 cookie API remainder** — quick partial completion
|
||||
4. **#17 / #22 / #34 / #35** — small fiddly fixes, one sit-down each
|
||||
5. **Bucket E** — pick one subsystem at a time. **#39 (WebWorker stub) first** — single commit, smallest. Then **#38 (SourceInfo)** — 4 commits. Then the bigger three (#36, #37, #40).
|
||||
6. **Bucket F** — generator repair sweep at the end.
|
||||
|
||||
Estimated total to 100%: ~10-15 days of focused work, parallelisable across branches.
|
||||
|
||||
## Cluster #31 spec (full detail)
|
||||
|
||||
The plan note from `hs-conformance-to-100.md`:
|
||||
|
||||
> 18 tests in `runtimeErrors`. When accessing `.foo` on nil, emit a structured error with position info. One coordinated fix in the compiler emit paths for property access, function calls, set/put.
|
||||
|
||||
**Required pieces:**
|
||||
|
||||
1. **Generator-side `eval-hs-error` helper + recognizer** for `expect(await error("HS")).toBe("MSG")` blocks. In `tests/playwright/generate-sx-tests.py`.
|
||||
2. **Runtime helpers** in `lib/hyperscript/runtime.sx`:
|
||||
- `hs-null-error!` raising `'<sel>' is null`
|
||||
- `hs-named-target` — wraps a query result with the original selector source
|
||||
- `hs-named-target-list` — same for list results
|
||||
3. **Compiler patches at every target-position `(query SEL)` emit** — wrap in named-target carrying the original selector source. ~17 command emit paths in `lib/hyperscript/compiler.sx`:
|
||||
add, remove, hide, show, measure, settle, trigger, send, set, default, increment, decrement, put, toggle, transition, append, take.
|
||||
4. **Function-call null-check** at bare `(name)`, `hs-method-call`, and `host-get` chains, deriving the leftmost-uncalled-name (`'x'` / `'x.y'`) from the parse tree.
|
||||
5. **Possessive-base null-check** (`set x's y to true` → `'x' is null`).
|
||||
|
||||
**Files in scope:**
|
||||
- `lib/hyperscript/runtime.sx` (new helpers)
|
||||
- `lib/hyperscript/compiler.sx` (~17 emit-path edits)
|
||||
- `tests/playwright/generate-sx-tests.py` (test recognizer)
|
||||
- `tests/hs-run-filtered.js` (if mock helpers needed)
|
||||
- `shared/static/wasm/sx/hs-runtime.sx` + `hs-compiler.sx` (WASM staging copies)
|
||||
|
||||
**Approach:** target-named pieces incrementally — runtime helpers first (no compiler change), then compiler emit paths in batches (group similar commands), then function-call/possessive at the end. Each batch is one commit if it lands +N tests; mark partial if it only unlocks part.
|
||||
|
||||
**Watch for:** smoke-range regressions (tests flipping pass→fail). Each commit: rerun smoke 0-195 and the `runtimeErrors` suite.
|
||||
|
||||
## Notes for future sessions
|
||||
|
||||
- `plans/hs-conformance-to-100.md` is the canonical cluster ledger — update it on every commit.
|
||||
- `plans/hs-conformance-scoreboard.md` is the live tally — bump `Merged:` and the bucket roll-up.
|
||||
- Loop has scope rule "never edit `spec/evaluator.sx` or broader SX kernel" — most fixes here stay in `lib/hyperscript/**`, `tests/`, generator. If a fix needs kernel work, surface to the user; don't merge silently.
|
||||
- Cluster #22's `symbol-bound?` predicate would be a kernel addition — that's a real cross-boundary scope expansion.
|
||||
124
plans/ruby-on-sx.md
Normal file
124
plans/ruby-on-sx.md
Normal file
@@ -0,0 +1,124 @@
|
||||
# Ruby-on-SX: fibers + blocks + open classes on delimited continuations
|
||||
|
||||
The headline showcase is **fibers** — Ruby's `Fiber.new { … Fiber.yield v … }` / `Fiber.resume` are textbook delimited continuations with sugar. MRI implements them by swapping C stacks; on SX they fall out of the existing `perform`/`cek-resume` machinery for free. Plus blocks/yield (lexical escape continuations, same shape as Smalltalk's non-local return), method_missing, and singleton classes.
|
||||
|
||||
End-state goal: Ruby 2.7-flavoured subset, Enumerable mixin, fibers + threads-via-fibers (no real OS threads), method_missing-driven DSLs, ~150 hand-written + classic programs.
|
||||
|
||||
## Scope decisions (defaults — override by editing before we spawn)
|
||||
|
||||
- **Syntax:** Ruby 2.7. No 3.x pattern matching, no rightward assignment, no endless methods. We pick 2.7 because it's the biggest semantic surface that still parses cleanly.
|
||||
- **Conformance:** "Reads like Ruby, runs like Ruby." Slice of RubySpec (Core + Library subset), not full RubySpec.
|
||||
- **Test corpus:** custom + curated RubySpec slice. Plus classic programs: fiber-based generator, internal DSL with method_missing, mixin-based Enumerable on a custom class.
|
||||
- **Out of scope:** real threads, GIL, refinements, `binding_of_caller` from non-Ruby contexts, Encoding object beyond UTF-8/ASCII-8BIT, RubyVM::* introspection beyond bytecode-disassembly placeholder, IO subsystem beyond `puts`/`gets`/`File.read`.
|
||||
- **Symbols:** SX symbols. Strings are mutable copies; symbols are interned.
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/ruby/**` and `plans/ruby-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. Ruby primitives go in `lib/ruby/runtime.sx`.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
Ruby source
|
||||
│
|
||||
▼
|
||||
lib/ruby/tokenizer.sx — keywords, ops, %w[], %i[], heredocs (deferred), regex (deferred)
|
||||
│
|
||||
▼
|
||||
lib/ruby/parser.sx — AST: classes, modules, methods, blocks, calls
|
||||
│
|
||||
▼
|
||||
lib/ruby/transpile.sx — AST → SX AST (entry: rb-eval-ast)
|
||||
│
|
||||
▼
|
||||
lib/ruby/runtime.sx — class table, MOP, dispatch, fibers, primitives
|
||||
```
|
||||
|
||||
Core mapping:
|
||||
- **Object** = SX dict `{:class :ivars :singleton-class?}`. Instance variables live in `ivars` keyed by symbol.
|
||||
- **Class** = SX dict `{:name :superclass :methods :class-methods :metaclass :includes :prepends}`. Class table is flat.
|
||||
- **Method dispatch** = lookup walks ancestor chain (prepended → class → included modules → superclass → …). Falls back to `method_missing` with a `Symbol`+args.
|
||||
- **Block** = lambda + escape continuation. `yield` invokes the block in current context. `return` from within a block invokes the enclosing-method's escape continuation.
|
||||
- **Proc** = lambda without strict arity. `Proc.new` + `proc {}`.
|
||||
- **Lambda** = lambda with strict arity + `return`-returns-from-lambda semantics.
|
||||
- **Fiber** = pair of continuations (resume-k, yield-k) wrapped in a record. `Fiber.new { … }` builds it; `Fiber.resume` invokes the resume-k; `Fiber.yield` invokes the yield-k. Built directly on `perform`/`cek-resume`.
|
||||
- **Module** = class without instance allocation. `include` puts it in the chain; `prepend` puts it earlier; `extend` puts it on the singleton.
|
||||
- **Singleton class** = lazily allocated per-object class for `def obj.foo` definitions.
|
||||
- **Symbol** = interned SX symbol. `:foo` reads as `(quote foo)` flavour.
|
||||
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — tokenizer + parser
|
||||
- [ ] Tokenizer: keywords (`def end class module if unless while until do return yield begin rescue ensure case when then else elsif`), identifiers (lowercase = local/method, `@` = ivar, `@@` = cvar, `$` = global, uppercase = constant), numbers (int, float, `0x` `0o` `0b`, `_` separators), strings (`"…"` interpolation, `'…'` literal, `%w[a b c]`, `%i[a b c]`), symbols `:foo` `:"…"`, operators (`+ - * / % ** == != < > <= >= <=> === =~ !~ << >> & | ^ ~ ! && || and or not`), `:: . , ; ( ) [ ] { } -> => |`, comments `#`
|
||||
- [ ] Parser: program is sequence of statements separated by newlines or `;`; method def `def name(args) … end`; class `class Foo < Bar … end`; module `module M … end`; block `do |a, b| … end` and `{ |a, b| … }`; call sugar (no parens), `obj.method`, `Mod::Const`; arg shapes (positional, default, splat `*args`, double-splat `**opts`, block `&blk`)
|
||||
- [ ] If/while/case expressions (return values), `unless`/`until`, postfix modifiers
|
||||
- [ ] Begin/rescue/ensure/retry, raise, raise with class+message
|
||||
- [ ] Unit tests in `lib/ruby/tests/parse.sx`
|
||||
|
||||
### Phase 2 — object model + sequential eval
|
||||
- [ ] Class table bootstrap: `BasicObject`, `Object`, `Kernel`, `Module`, `Class`, `Numeric`, `Integer`, `Float`, `String`, `Symbol`, `Array`, `Hash`, `Range`, `NilClass`, `TrueClass`, `FalseClass`, `Proc`, `Method`
|
||||
- [ ] `rb-eval-ast`: literals, variables (local, ivar, cvar, gvar, constant), assignment (single and parallel `a, b = 1, 2`, splat receive), method call, message dispatch
|
||||
- [ ] Method lookup walks ancestor chain; cache hit-class per `(class, selector)`
|
||||
- [ ] `method_missing` fallback constructing args list
|
||||
- [ ] `super` and `super(args)` — lookup in defining class's superclass
|
||||
- [ ] Singleton class allocation on first `def obj.foo` or `class << obj`
|
||||
- [ ] `nil`, `true`, `false` are singletons of their classes; tagged values aren't boxed
|
||||
- [ ] Constant lookup (lexical-then-inheritance) with `Module.nesting`
|
||||
- [ ] 60+ tests in `lib/ruby/tests/eval.sx`
|
||||
|
||||
### Phase 3 — blocks + procs + lambdas
|
||||
- [ ] Method invocation captures escape continuation `^k` for `return`; binds it as block's escape
|
||||
- [ ] `yield` invokes implicit block
|
||||
- [ ] `block_given?`, `&blk` parameter, `&proc` arg unpacking
|
||||
- [ ] `Proc.new`, `proc { }`, `lambda { }` (or `->(x) { x }`)
|
||||
- [ ] Lambda strict arity + lambda-local `return` semantics
|
||||
- [ ] Proc lax arity (`a, b, c` unpacks Array; missing args nil)
|
||||
- [ ] `break`, `next`, `redo` — `break` is escape-from-loop-or-block; `next` is escape-from-block-iteration; `redo` re-runs current iteration
|
||||
- [ ] 30+ tests in `lib/ruby/tests/blocks.sx`
|
||||
|
||||
### Phase 4 — fibers (THE SHOWCASE)
|
||||
- [ ] `Fiber.new { |arg| … Fiber.yield v … }` allocates a fiber record with paired continuations
|
||||
- [ ] `Fiber.resume(args…)` resumes the fiber, returning the value passed to `Fiber.yield`
|
||||
- [ ] `Fiber.yield(v)` from inside the fiber suspends and returns control to the resumer
|
||||
- [ ] `Fiber.current` from inside the fiber
|
||||
- [ ] `Fiber#alive?`, `Fiber#raise` (deferred)
|
||||
- [ ] `Fiber.transfer` — symmetric coroutines (resume from any side)
|
||||
- [ ] Classic programs in `lib/ruby/tests/programs/`:
|
||||
- [ ] `generator.rb` — pull-style infinite enumerator built on fibers
|
||||
- [ ] `producer-consumer.rb` — bounded buffer with `Fiber.transfer`
|
||||
- [ ] `tree-walk.rb` — recursive tree walker that yields each node, driven by `Fiber.resume`
|
||||
- [ ] `lib/ruby/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
||||
|
||||
### Phase 5 — modules + mixins + metaprogramming
|
||||
- [ ] `include M` — appends M's methods after class methods in chain
|
||||
- [ ] `prepend M` — prepends M before class methods
|
||||
- [ ] `extend M` — adds M to singleton class
|
||||
- [ ] `Module#ancestors`, `Module#included_modules`
|
||||
- [ ] `define_method`, `class_eval`, `instance_eval`, `module_eval`
|
||||
- [ ] `respond_to?`, `respond_to_missing?`, `method_missing`
|
||||
- [ ] `Object#send`, `Object#public_send`, `Object#__send__`
|
||||
- [ ] `Module#method_added`, `singleton_method_added` hooks
|
||||
- [ ] Hooks: `included`, `extended`, `inherited`, `prepended`
|
||||
- [ ] Internal-DSL classic program: `lib/ruby/tests/programs/dsl.rb`
|
||||
|
||||
### Phase 6 — stdlib drive
|
||||
- [ ] `Enumerable` mixin: `each` (abstract), `map`, `select`/`filter`, `reject`, `reduce`/`inject`, `each_with_index`, `each_with_object`, `take`, `drop`, `take_while`, `drop_while`, `find`/`detect`, `find_index`, `any?`, `all?`, `none?`, `one?`, `count`, `min`, `max`, `min_by`, `max_by`, `sort`, `sort_by`, `group_by`, `partition`, `chunk`, `each_cons`, `each_slice`, `flat_map`, `lazy`
|
||||
- [ ] `Comparable` mixin: `<=>`, `<`, `<=`, `>`, `>=`, `==`, `between?`, `clamp`
|
||||
- [ ] `Array`: indexing, slicing, `push`/`pop`/`shift`/`unshift`, `concat`, `flatten`, `compact`, `uniq`, `sort`, `reverse`, `zip`, `dig`, `pack`/`unpack` (deferred)
|
||||
- [ ] `Hash`: `[]`, `[]=`, `delete`, `merge`, `each_pair`, `keys`, `values`, `to_a`, `dig`, `fetch`, default values, default proc
|
||||
- [ ] `Range`: `each`, `step`, `cover?`, `include?`, `size`, `min`, `max`
|
||||
- [ ] `String`: indexing, slicing, `split`, `gsub` (string-arg version, regex deferred), `sub`, `upcase`, `downcase`, `strip`, `chomp`, `chars`, `bytes`, `to_i`, `to_f`, `to_sym`, `*`, `+`, `<<`, format with `%`
|
||||
- [ ] `Integer`: `times`, `upto`, `downto`, `step`, `digits`, `gcd`, `lcm`
|
||||
- [ ] Drive corpus to 200+ green
|
||||
|
||||
## Progress log
|
||||
|
||||
_Newest first._
|
||||
|
||||
- _(none yet)_
|
||||
|
||||
## Blockers
|
||||
|
||||
- _(none yet)_
|
||||
@@ -50,100 +50,64 @@ Core mapping:
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — tokenizer + parser
|
||||
- [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 `<primitive: …>` (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`
|
||||
- [ ] 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 `<primitive: 1>`, blocks `[:a :b | | t1 t2 | …]`, cascades, message precedence (unary > binary > keyword)
|
||||
- [ ] Unit tests in `lib/smalltalk/tests/parse.sx`
|
||||
|
||||
### Phase 2 — object model + sequential eval
|
||||
- [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)
|
||||
- [ ] 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`
|
||||
|
||||
### Phase 3 — blocks + non-local return (THE SHOWCASE)
|
||||
- [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.
|
||||
- [ ] 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`
|
||||
|
||||
### Phase 4 — reflection + MOP
|
||||
- [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.
|
||||
- [ ] `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`
|
||||
|
||||
### Phase 5 — collections + numeric tower
|
||||
- [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.
|
||||
- [ ] `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
|
||||
|
||||
### Phase 6 — SUnit + corpus to 200+
|
||||
- [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.
|
||||
- [ ] 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
|
||||
|
||||
### Phase 7 — speed (optional)
|
||||
- [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.**
|
||||
- [ ] 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
|
||||
|
||||
## Progress log
|
||||
|
||||
_Newest first. Agent appends on every commit._
|
||||
|
||||
- 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.
|
||||
- _(none yet)_
|
||||
|
||||
## Blockers
|
||||
|
||||
|
||||
128
plans/tcl-on-sx.md
Normal file
128
plans/tcl-on-sx.md
Normal file
@@ -0,0 +1,128 @@
|
||||
# Tcl-on-SX: uplevel/upvar = stack-walking delcc, everything-is-a-string
|
||||
|
||||
The headline showcase is **uplevel/upvar** — Tcl's superpower for defining your own control structures. `uplevel` evaluates a script in the *caller's* stack frame; `upvar` aliases a variable in the caller. On a normal language host this requires deep VM cooperation; on SX it falls out of the env-chain made first-class via captured continuations. Plus the *Dodekalogue* (12 rules), command-substitution everywhere, and "everything is a string" homoiconicity.
|
||||
|
||||
End-state goal: Tcl 8.6-flavoured subset, the Dodekalogue parser, namespaces, `try`/`catch`/`return -code`, `coroutine` (built on fibers), classic programs that show off uplevel-driven DSLs, ~150 hand-written tests.
|
||||
|
||||
## Scope decisions (defaults — override by editing before we spawn)
|
||||
|
||||
- **Syntax:** Tcl 8.6 surface. The 12-rule Dodekalogue. Brace-quoted scripts deferred-evaluate; double-quoted ones substitute.
|
||||
- **Conformance:** "Reads like Tcl, runs like Tcl." Slice of Tcl's own test suite, not full TCT.
|
||||
- **Test corpus:** custom + curated `tcl-tests/` slice. Plus classic programs: define-your-own `for-each-line`, expression-language compiler-in-Tcl, fiber-based event loop.
|
||||
- **Out of scope:** Tk, sockets beyond a stub, threads (mapped to `coroutine` only), `package require` of binary loadables, `dde`/`registry` Windows shims, full `clock format` locale support.
|
||||
- **Channels:** `puts` and `gets` on `stdout`/`stdin`/`stderr`; `open` on regular files; no async I/O beyond what `coroutine` gives.
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/tcl/**` and `plans/tcl-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. Tcl primitives go in `lib/tcl/runtime.sx`.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
Tcl source
|
||||
│
|
||||
▼
|
||||
lib/tcl/tokenizer.sx — the Dodekalogue: words, [..], ${..}, "..", {..}, ;, \n, \, #
|
||||
│
|
||||
▼
|
||||
lib/tcl/parser.sx — list-of-words AST (script = list of commands; command = list of words)
|
||||
│
|
||||
▼
|
||||
lib/tcl/transpile.sx — AST → SX AST (entry: tcl-eval-script)
|
||||
│
|
||||
▼
|
||||
lib/tcl/runtime.sx — env stack, command table, uplevel/upvar, coroutines, BIFs
|
||||
```
|
||||
|
||||
Core mapping:
|
||||
- **Value** = string. Internally we cache a "shimmer" representation (list, dict, integer, double) for performance, but every value can be re-stringified.
|
||||
- **Variable** = entry in current frame's env. Frames form a stack; level-0 is the global frame.
|
||||
- **Command** = entry in command table; first word of any list dispatches into it. User-defined via `proc`. Built-ins are SX functions registered in the table.
|
||||
- **Frame** = `{:locals (dict) :level n :parent frame}`. Each `proc` call pushes a frame; commands run in current frame.
|
||||
- **`uplevel #N script`** = walk frame chain to absolute level N (or relative if no `#`); evaluate script in that frame's env.
|
||||
- **`upvar [#N] varname localname`** = bind `localname` in the current frame as an alias to `varname` in the level-N frame (env-chain delegate).
|
||||
- **`return -code N`** = control flow as integers: 0=ok, 1=error, 2=return, 3=break, 4=continue. `catch` traps any non-zero; `try` adds named handlers.
|
||||
- **`coroutine`** = fiber on top of `perform`/`cek-resume`. `yield`/`yieldto` suspend; calling the coroutine command resumes.
|
||||
- **List / dict** = list-shaped string ("element1 element2 …") with a cached parsed form. Modifications dirty the string cache.
|
||||
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — tokenizer + parser (the Dodekalogue)
|
||||
- [x] Tokenizer applying the 12 rules:
|
||||
1. Commands separated by `;` or newlines
|
||||
2. Words separated by whitespace within a command
|
||||
3. Double-quoted words: `\` escapes + `[…]` + `${…}` + `$var` substitution
|
||||
4. Brace-quoted words: literal, no substitution; brace count must balance
|
||||
5. Argument expansion: `{*}list`
|
||||
6. Command substitution: `[script]` evaluates script, takes its return value
|
||||
7. Variable substitution: `$name`, `${name}`, `$arr(idx)`, `$arr($i)`
|
||||
8. Backslash substitution: `\n`, `\t`, `\\`, `\xNN`, `\uNNNN`, `\<newline>` continues
|
||||
9. Comments: `#` only at the start of a command
|
||||
10. Order of substitution is left-to-right, single-pass
|
||||
11. Substitutions don't recurse — substituted text is not re-parsed
|
||||
12. The result of any substitution is the value, not a new script
|
||||
- [x] Parser: script = list of commands; command = list of words; word = literal string + list of substitutions
|
||||
- [x] Unit tests in `lib/tcl/tests/parse.sx`
|
||||
|
||||
### Phase 2 — sequential eval + core commands
|
||||
- [ ] `tcl-eval-script`: walk command list, dispatch each first-word into command table
|
||||
- [ ] Core commands: `set`, `unset`, `incr`, `append`, `lappend`, `puts`, `gets`, `expr`, `if`, `while`, `for`, `foreach`, `switch`, `break`, `continue`, `return`, `error`, `eval`, `subst`, `format`, `scan`
|
||||
- [ ] `expr` is its own mini-language — operator precedence, function calls (`sin`, `sqrt`, `pow`, `abs`, `int`, `double`), variable substitution, command substitution
|
||||
- [ ] String commands: `string length`, `string index`, `string range`, `string compare`, `string match`, `string toupper`, `string tolower`, `string trim`, `string map`, `string repeat`, `string first`, `string last`, `string is`, `string cat`
|
||||
- [ ] List commands: `list`, `lindex`, `lrange`, `llength`, `lreverse`, `lsearch`, `lsort`, `lsort -integer/-real/-dictionary`, `lreplace`, `linsert`, `concat`, `split`, `join`
|
||||
- [ ] Dict commands: `dict create`, `dict get`, `dict set`, `dict unset`, `dict exists`, `dict keys`, `dict values`, `dict size`, `dict for`, `dict update`, `dict merge`
|
||||
- [ ] 60+ tests in `lib/tcl/tests/eval.sx`
|
||||
|
||||
### Phase 3 — proc + uplevel + upvar (THE SHOWCASE)
|
||||
- [ ] `proc name args body` — register user-defined command; args supports defaults `{name default}` and rest `args`
|
||||
- [ ] Frame stack: each proc call pushes a frame with locals dict; pop on return
|
||||
- [ ] `uplevel ?level? script` — evaluate `script` in level-N frame's env; default level is 1 (caller). `#0` is global, `#1` is relative-1
|
||||
- [ ] `upvar ?level? otherVar localVar ?…?` — alias localVar to a variable in level-N frame; reads/writes go through the alias
|
||||
- [ ] `info level`, `info level N`, `info frame`, `info vars`, `info locals`, `info globals`, `info commands`, `info procs`, `info args`, `info body`
|
||||
- [ ] `global var ?…?` — alias to global frame (sugar for `upvar #0 var var`)
|
||||
- [ ] `variable name ?value?` — namespace-scoped global
|
||||
- [ ] Classic programs in `lib/tcl/tests/programs/`:
|
||||
- [ ] `for-each-line.tcl` — define your own loop construct using `uplevel`
|
||||
- [ ] `assert.tcl` — assertion macro that reports caller's line
|
||||
- [ ] `with-temp-var.tcl` — scoped variable rebind via `upvar`
|
||||
- [ ] `lib/tcl/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
||||
|
||||
### Phase 4 — control flow + error handling
|
||||
- [ ] `return -code (ok|error|return|break|continue|N) -errorinfo … -errorcode … -level N value`
|
||||
- [ ] `catch script ?resultVar? ?optionsVar?` — runs script, returns code; sets resultVar to return value/message; optionsVar to the dict
|
||||
- [ ] `try script ?on code var body ...? ?trap pattern var body...? ?finally body?`
|
||||
- [ ] `throw type message`
|
||||
- [ ] `error message ?info? ?code?`
|
||||
- [ ] Stack-trace with `errorInfo` / `errorCode`
|
||||
- [ ] 30+ tests in `lib/tcl/tests/error.sx`
|
||||
|
||||
### Phase 5 — namespaces + ensembles
|
||||
- [ ] `namespace eval ns body`, `namespace current`, `namespace which`, `namespace import`, `namespace export`, `namespace forget`, `namespace delete`
|
||||
- [ ] Qualified names: `::ns::cmd`, `::ns::var`
|
||||
- [ ] Ensembles: `namespace ensemble create -map { sub1 cmd1 sub2 cmd2 }`
|
||||
- [ ] `namespace path` for resolution chain
|
||||
- [ ] `proc` and `variable` work inside namespaces
|
||||
|
||||
### Phase 6 — coroutines + drive corpus
|
||||
- [ ] `coroutine name cmd ?args…?` — start a coroutine; future calls to `name` resume it
|
||||
- [ ] `yield ?value?` — suspend, return value to resumer
|
||||
- [ ] `yieldto cmd ?args…?` — symmetric transfer
|
||||
- [ ] `coroutine` semantics built on fibers (same delcc primitive as Ruby fibers)
|
||||
- [ ] Classic programs: `event-loop.tcl` — cooperative scheduler with multiple coroutines
|
||||
- [ ] System: `clock seconds`, `clock format`, `clock scan` (subset)
|
||||
- [ ] File I/O: `open`, `close`, `read`, `gets`, `puts -nonewline`, `flush`, `eof`, `seek`, `tell`
|
||||
- [ ] Drive corpus to 150+ green
|
||||
- [ ] Idiom corpus — `lib/tcl/tests/idioms.sx` covering classic Welch/Jones idioms
|
||||
|
||||
## Progress log
|
||||
|
||||
_Newest first._
|
||||
|
||||
- 2026-04-25: Phase 1 parser — `lib/tcl/parser.sx`, word-simple?/word-literal helpers, 67 tests green, commit 6ee05259
|
||||
- 2026-04-25: Phase 1 tokenizer (Dodekalogue) — `lib/tcl/tokenizer.sx`, 52 tests green, commit 666e29d5
|
||||
|
||||
## Blockers
|
||||
|
||||
- _(none yet)_
|
||||
@@ -30,7 +30,7 @@ fi
|
||||
|
||||
if [ "$CLEAN" = "1" ]; then
|
||||
cd "$(dirname "$0")/.."
|
||||
for lang in lua prolog forth erlang haskell js hs smalltalk; do
|
||||
for lang in lua prolog forth erlang haskell js hs smalltalk common-lisp apl ruby tcl; do
|
||||
wt="$WORKTREE_BASE/$lang"
|
||||
if [ -d "$wt" ]; then
|
||||
git worktree remove --force "$wt" 2>/dev/null || rm -rf "$wt"
|
||||
@@ -39,5 +39,5 @@ if [ "$CLEAN" = "1" ]; then
|
||||
done
|
||||
git worktree prune
|
||||
echo "Worktree branches (loops/<lang>) are preserved. Delete manually if desired:"
|
||||
echo " git branch -D loops/lua loops/prolog loops/forth loops/erlang loops/haskell loops/js loops/hs loops/smalltalk"
|
||||
echo " git branch -D loops/lua loops/prolog loops/forth loops/erlang loops/haskell loops/js loops/hs loops/smalltalk loops/common-lisp loops/apl loops/ruby loops/tcl"
|
||||
fi
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
#!/usr/bin/env bash
|
||||
# Spawn 8 claude sessions in tmux, one per language loop.
|
||||
# Spawn 12 claude sessions in tmux, one per language loop.
|
||||
# Each runs in its own git worktree rooted at /root/rose-ash-loops/<lang>,
|
||||
# on branch loops/<lang>. No two loops share a working tree, so there's
|
||||
# zero risk of file collisions between languages.
|
||||
@@ -9,7 +9,7 @@
|
||||
#
|
||||
# After the script prints done:
|
||||
# tmux a -t sx-loops
|
||||
# Ctrl-B + <window-number> to switch (0=lua ... 7=smalltalk)
|
||||
# Ctrl-B + <window-number> to switch (0=lua ... 11=tcl)
|
||||
# Ctrl-B + d to detach (loops keep running, SSH-safe)
|
||||
#
|
||||
# Stop: ./scripts/sx-loops-down.sh
|
||||
@@ -39,8 +39,12 @@ declare -A BRIEFING=(
|
||||
[js]=loop.md
|
||||
[hs]=hs-loop.md
|
||||
[smalltalk]=smalltalk-loop.md
|
||||
[common-lisp]=common-lisp-loop.md
|
||||
[apl]=apl-loop.md
|
||||
[ruby]=ruby-loop.md
|
||||
[tcl]=tcl-loop.md
|
||||
)
|
||||
ORDER=(lua prolog forth erlang haskell js hs smalltalk)
|
||||
ORDER=(lua prolog forth erlang haskell js hs smalltalk common-lisp apl ruby tcl)
|
||||
|
||||
mkdir -p "$WORKTREE_BASE"
|
||||
|
||||
@@ -61,13 +65,13 @@ for lang in "${ORDER[@]}"; do
|
||||
fi
|
||||
done
|
||||
|
||||
# Create tmux session with 7 windows, each cwd in its worktree
|
||||
# Create tmux session with one window per language, each cwd in its worktree
|
||||
tmux new-session -d -s "$SESSION" -n "${ORDER[0]}" -c "$WORKTREE_BASE/${ORDER[0]}"
|
||||
for lang in "${ORDER[@]:1}"; do
|
||||
tmux new-window -t "$SESSION" -n "$lang" -c "$WORKTREE_BASE/$lang"
|
||||
done
|
||||
|
||||
echo "Starting 8 claude sessions..."
|
||||
echo "Starting ${#ORDER[@]} claude sessions..."
|
||||
for lang in "${ORDER[@]}"; do
|
||||
tmux send-keys -t "$SESSION:$lang" "claude" C-m
|
||||
done
|
||||
@@ -90,10 +94,10 @@ for lang in "${ORDER[@]}"; do
|
||||
done
|
||||
|
||||
echo ""
|
||||
echo "Done. 8 loops started in tmux session '$SESSION', each in its own worktree."
|
||||
echo "Done. ${#ORDER[@]} loops started in tmux session '$SESSION', each in its own worktree."
|
||||
echo ""
|
||||
echo " Attach: tmux a -t $SESSION"
|
||||
echo " Switch: Ctrl-B <0..7> (0=lua 1=prolog 2=forth 3=erlang 4=haskell 5=js 6=hs 7=smalltalk)"
|
||||
echo " Switch: Ctrl-B <0..11> (0=lua 1=prolog 2=forth 3=erlang 4=haskell 5=js 6=hs 7=smalltalk 8=common-lisp 9=apl 10=ruby 11=tcl)"
|
||||
echo " List: Ctrl-B w"
|
||||
echo " Detach: Ctrl-B d"
|
||||
echo " Stop: ./scripts/sx-loops-down.sh"
|
||||
|
||||
@@ -88,6 +88,27 @@
|
||||
(raise _e))))
|
||||
(handler me-val))))))
|
||||
|
||||
;; Evaluate a hyperscript expression, catch the first error raised, and
|
||||
;; return its message string. Used by runtimeErrors tests.
|
||||
;; Returns nil if no error is raised (test would then fail equality).
|
||||
(define eval-hs-error
|
||||
(fn (src)
|
||||
(let ((sx (hs-to-sx (hs-compile src))))
|
||||
(let ((handler (eval-expr-cek
|
||||
(list (quote fn) (list (quote me))
|
||||
(list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx)))))
|
||||
(guard
|
||||
(_e
|
||||
(true
|
||||
(if
|
||||
(string? _e)
|
||||
_e
|
||||
(if
|
||||
(and (list? _e) (= (first _e) "hs-return"))
|
||||
nil
|
||||
(str _e)))))
|
||||
(begin (handler nil) nil))))))
|
||||
|
||||
;; ── add (19 tests) ──
|
||||
(defsuite "hs-upstream-add"
|
||||
(deftest "can add a value to a set"
|
||||
@@ -2153,41 +2174,75 @@
|
||||
;; ── core/runtimeErrors (18 tests) ──
|
||||
(defsuite "hs-upstream-core/runtimeErrors"
|
||||
(deftest "reports basic function invocation null errors properly"
|
||||
(error "SKIP (untranslated): reports basic function invocation null errors properly"))
|
||||
(assert= (eval-hs-error "x()") "'x' is null")
|
||||
(assert= (eval-hs-error "x.y()") "'x' is null")
|
||||
(assert= (eval-hs-error "x.y.z()") "'x.y' is null")
|
||||
)
|
||||
(deftest "reports basic function invocation null errors properly w/ of"
|
||||
(error "SKIP (untranslated): reports basic function invocation null errors properly w/ of"))
|
||||
(assert= (eval-hs-error "z() of y of x") "'z' is null")
|
||||
)
|
||||
(deftest "reports basic function invocation null errors properly w/ possessives"
|
||||
(error "SKIP (untranslated): reports basic function invocation null errors properly w/ possessives"))
|
||||
(assert= (eval-hs-error "x's y()") "'x' is null")
|
||||
(assert= (eval-hs-error "x's y's z()") "'x's y' is null")
|
||||
)
|
||||
(deftest "reports null errors on add command properly"
|
||||
(error "SKIP (untranslated): reports null errors on add command properly"))
|
||||
(assert= (eval-hs-error "add .foo to #doesntExist") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "add @foo to #doesntExist") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "add {display:none} to #doesntExist") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on decrement command properly"
|
||||
(error "SKIP (untranslated): reports null errors on decrement command properly"))
|
||||
(assert= (eval-hs-error "decrement #doesntExist's innerHTML") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on default command properly"
|
||||
(error "SKIP (untranslated): reports null errors on default command properly"))
|
||||
(assert= (eval-hs-error "default #doesntExist's innerHTML to 'foo'") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on hide command properly"
|
||||
(error "SKIP (untranslated): reports null errors on hide command properly"))
|
||||
(assert= (eval-hs-error "hide #doesntExist") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on increment command properly"
|
||||
(error "SKIP (untranslated): reports null errors on increment command properly"))
|
||||
(assert= (eval-hs-error "increment #doesntExist's innerHTML") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on measure command properly"
|
||||
(error "SKIP (untranslated): reports null errors on measure command properly"))
|
||||
(assert= (eval-hs-error "measure #doesntExist") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on put command properly"
|
||||
(error "SKIP (untranslated): reports null errors on put command properly"))
|
||||
(assert= (eval-hs-error "put 'foo' into #doesntExist") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "put 'foo' into #doesntExist's innerHTML") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "put 'foo' into #doesntExist.innerHTML") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "put 'foo' before #doesntExist") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "put 'foo' after #doesntExist") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "put 'foo' at the start of #doesntExist") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "put 'foo' at the end of #doesntExist") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on remove command properly"
|
||||
(error "SKIP (untranslated): reports null errors on remove command properly"))
|
||||
(assert= (eval-hs-error "remove .foo from #doesntExist") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "remove @foo from #doesntExist") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "remove #doesntExist from #doesntExist") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on send command properly"
|
||||
(error "SKIP (untranslated): reports null errors on send command properly"))
|
||||
(assert= (eval-hs-error "send 'foo' to #doesntExist") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on sets properly"
|
||||
(error "SKIP (untranslated): reports null errors on sets properly"))
|
||||
(assert= (eval-hs-error "set x's y to true") "'x' is null")
|
||||
(assert= (eval-hs-error "set x's @y to true") "'x' is null")
|
||||
)
|
||||
(deftest "reports null errors on settle command properly"
|
||||
(error "SKIP (untranslated): reports null errors on settle command properly"))
|
||||
(assert= (eval-hs-error "settle #doesntExist") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on show command properly"
|
||||
(error "SKIP (untranslated): reports null errors on show command properly"))
|
||||
(assert= (eval-hs-error "show #doesntExist") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on toggle command properly"
|
||||
(error "SKIP (untranslated): reports null errors on toggle command properly"))
|
||||
(assert= (eval-hs-error "toggle .foo on #doesntExist") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "toggle between .foo and .bar on #doesntExist") "'#doesntExist' is null")
|
||||
(assert= (eval-hs-error "toggle @foo on #doesntExist") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on transition command properly"
|
||||
(error "SKIP (untranslated): reports null errors on transition command properly"))
|
||||
(assert= (eval-hs-error "transition #doesntExist's *visibility to 0") "'#doesntExist' is null")
|
||||
)
|
||||
(deftest "reports null errors on trigger command properly"
|
||||
(error "SKIP (untranslated): reports null errors on trigger command properly"))
|
||||
(assert= (eval-hs-error "trigger 'foo' on #doesntExist") "'#doesntExist' is null")
|
||||
)
|
||||
)
|
||||
|
||||
;; ── core/scoping (20 tests) ──
|
||||
|
||||
@@ -2333,6 +2333,25 @@ def generate_eval_only_test(test, idx):
|
||||
hs_expr = extract_hs_expr(m.group(2))
|
||||
assertions.append(f' (assert-throws (eval-hs "{hs_expr}"))')
|
||||
|
||||
# Pattern 4: eval-hs-error — expect(await error("expr")).toBe("msg")
|
||||
# These test that running HS raises an error with a specific message string.
|
||||
for m in re.finditer(
|
||||
r'(?:const\s+\w+\s*=\s*)?(?:await\s+)?error\((["\x27`])(.+?)\1\)'
|
||||
r'(?:[^;]|\n)*?(?:expect\([^)]*\)\.toBe\(([^)]+)\)|\.toBe\(([^)]+)\))',
|
||||
body, re.DOTALL
|
||||
):
|
||||
hs_expr = extract_hs_expr(m.group(2))
|
||||
expected_raw = (m.group(3) or m.group(4) or '').strip()
|
||||
# Strip only the outermost JS string delimiter (double or single quote)
|
||||
# without touching inner quotes inside the string value.
|
||||
if len(expected_raw) >= 2 and expected_raw[0] == expected_raw[-1] and expected_raw[0] in ('"', "'"):
|
||||
inner = expected_raw[1:-1]
|
||||
expected_sx = '"' + inner.replace('\\', '\\\\').replace('"', '\\"') + '"'
|
||||
else:
|
||||
expected_sx = js_val_to_sx(expected_raw)
|
||||
hs_escaped = hs_expr.replace('\\', '\\\\').replace('"', '\\"')
|
||||
assertions.append(f' (assert= (eval-hs-error "{hs_escaped}") {expected_sx})')
|
||||
|
||||
if not assertions:
|
||||
return None # Can't convert this body pattern
|
||||
|
||||
@@ -2692,6 +2711,27 @@ output.append(' (nth _e 1)')
|
||||
output.append(' (raise _e))))')
|
||||
output.append(' (handler me-val))))))')
|
||||
output.append('')
|
||||
output.append(';; Evaluate a hyperscript expression, catch the first error raised, and')
|
||||
output.append(';; return its message string. Used by runtimeErrors tests.')
|
||||
output.append(';; Returns nil if no error is raised (test would then fail equality).')
|
||||
output.append('(define eval-hs-error')
|
||||
output.append(' (fn (src)')
|
||||
output.append(' (let ((sx (hs-to-sx (hs-compile src))))')
|
||||
output.append(' (let ((handler (eval-expr-cek')
|
||||
output.append(' (list (quote fn) (list (quote me))')
|
||||
output.append(' (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx)))))')
|
||||
output.append(' (guard')
|
||||
output.append(' (_e')
|
||||
output.append(' (true')
|
||||
output.append(' (if')
|
||||
output.append(' (string? _e)')
|
||||
output.append(' _e')
|
||||
output.append(' (if')
|
||||
output.append(' (and (list? _e) (= (first _e) "hs-return"))')
|
||||
output.append(' nil')
|
||||
output.append(' (str _e)))))')
|
||||
output.append(' (begin (handler nil) nil))))))')
|
||||
output.append('')
|
||||
|
||||
# Group by category
|
||||
categories = OrderedDict()
|
||||
|
||||
Reference in New Issue
Block a user