;; 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)) (list st-test-pass st-test-fail)