giles
e6af4e1449
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
146 lines
4.2 KiB
Plaintext
146 lines
4.2 KiB
Plaintext
;; 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)
|
|
|
|
(list st-test-pass st-test-fail)
|