commit 745be7bc9782c92d9a0166bc5c1d3f11ad5737f5 Spenser Truex <truex@equwal.com> 2026-10-04 09:05:44 +0000 R7RS item 3: sqrt per R7RS, rounding on non-integers
NOTES.md | 7 ++++--- README.md | 4 ++-- conformance.txt | 2 +- lisp.fs | 3 +++ prelude.scm | 13 +++++++------ r7rs-tests.scm | 23 ++++++++++++++++++++++- tests/r7rs/results.txt | 30 +----------------------------- 7 files changed, 40 insertions(+), 42 deletions(-)
diff --git a/NOTES.md b/NOTES.md index ae64687..c562a8f 100644 --- a/NOTES.md +++ b/NOTES.md @@ -114,7 +114,7 @@ What this design takes from them: | 1-2 assembler | `asm-test.lisp`: every encoder form vs `arm-none-eabi-as` (incl. FPv4-SP), plus repeated label references | 105/105 | | 3 kernel | `forth-tests.txt` via `host.lisp ktest`, fresh boot | 71/71 | | 4 Scheme | chibi-scheme's R7RS suite, `tests/r7rs/`, via `host.lisp suite` | see `tests/r7rs/results.txt` | -| 4 Scheme | our own regression suite `r7rs-tests.scm` via `host.lisp test` | 297/297 | +| 4 Scheme | our own regression suite `r7rs-tests.scm` via `host.lisp test` | 317/317 | - Kernel image: about 10.4 KiB of flash, 197 words (FPU words `f+ f- f* f/ s>f f>s fsqrt f< f=`). - RAM after `lisp.fs`, `prims.lisp` and `prelude.scm` load: @@ -145,7 +145,8 @@ What this design takes from them: - A form that errors counts all of its unreported tests as failed. If the chip stops answering, every later test counts as failed. - First run on the own stack: 244 passed, 78 failed, 810 skipped, 1132 total. After item 1 (numbers): 302 passed, 119 failed, 711 skipped. After item 2 (characters, - strings, vectors, bytevectors): 486 passed, 123 failed, 523 skipped. It found two + strings, vectors, bytevectors): 486 passed, 123 failed, 523 skipped. After item 3 (sqrt, + rounding): 500 passed, 109 failed, 523 skipped. It found two bugs, now fixed and covered by local regression tests: `list?` looped on a circular list, and `case` lacked `=>`. @@ -171,7 +172,7 @@ Our own suite below stays local: a reported sieve program, string cases and thos are 8-bit. Strings, vectors and bytevectors live in a 16 KiB blob heap, with O(1) access. The GC compacts live blobs. Missing from the string library: `string-fill!`, `string-copy!`, case conversion of whole strings, and `-ci` string comparisons. -- `sqrt` returns the exact integer floor of the root (`(sqrt 500)` is 22, not 22.36); `floor`, `round` and friends are the identity on integers. +- `sqrt` is exact for exact squares (`(sqrt 1/4)` is `1/2`) and inexact otherwise. A negative argument gives `+nan.0`, because there are no complex numbers. `exact-integer-sqrt` returns a list `(s r)` until multiple values exist. `floor`, `ceiling`, `truncate` and `round` (half to even) handle rationals and floats. No `exp`, `log` or trigonometry yet. - No `define-syntax`/`syntax-rules`, `quasiquote`, `delay`/`force`, `call/cc`, `dynamic-wind`, `values`, exceptions, `guard`, parameters, records, libraries (`import`), ports beyond the console. - Errors print a message and return to the prompt; they are not raisable objects. - Primitives check argument types but not arity; extra arguments are ignored. diff --git a/README.md b/README.md index d292e9f..42eb482 100644 --- a/README.md +++ b/README.md @@ -52,8 +52,8 @@ Needs SBCL, `qemu-system-arm`, `arm-none-eabi-as`/`objcopy` (for the assembler t ## Test counts (STM32F446 target, QEMU) -- Our regression suite: see `conformance.txt` (297/297 at publication) -- chibi-scheme R7RS suite: see `tests/r7rs/results.txt` (486 passed, 123 failed, 523 skipped +- Our regression suite: see `conformance.txt` (317/317 at publication) +- chibi-scheme R7RS suite: see `tests/r7rs/results.txt` (500 passed, 109 failed, 523 skipped of 1132 at publication; every skip names its reason) ## Limits diff --git a/conformance.txt b/conformance.txt index ba5c1c7..a5ff538 100644 --- a/conformance.txt +++ b/conformance.txt @@ -1 +1 @@ -conformance: 297 passed, 0 failed, 297 total +conformance: 317 passed, 0 failed, 317 total diff --git a/lisp.fs b/lisp.fs index 706c197..30a8e5d 100644 --- a/lisp.fs +++ b/lisp.fs @@ -475,11 +475,14 @@ token => intern constant s-=> : p-num ( args -- v ) car numden drop >fix ; : p-den ( args -- v ) car numden nip >fix ; : p-nan? ( args -- v ) car dup flo? if cdr dup $7F800000 and $7F800000 = swap $7FFFFF and 0<> and bool exit then drop #f ; +: p-ftrunc ( args -- v ) car cdr dup fint? if flo exit then f>s s>f flo ; \ toward zero +: p-fsqrt ( args -- v ) car >float fsqrt flo ; : p-inf? ( args -- v ) car dup flo? if cdr $7FFFFFFF and $7F800000 = bool exit then drop #f ; ' p-exact defprim exact ' p-inexact defprim inexact ' p-eqv defprim eqv? ' p-number? defprim number? ' p-number? defprim real? ' p-number? defprim complex? ' p-integer? defprim integer? ' p-rational? defprim rational? ' p-exact? defprim exact? ' p-inexact? defprim inexact? ' p-exint? defprim exact-integer? +' p-ftrunc defprim %ftruncate ' p-fsqrt defprim %fsqrt ' p-num defprim %numerator ' p-den defprim %denominator ' p-nan? defprim nan? ' p-inf? defprim infinite? ' p-apply defprim apply ' p-display defprim display ' p-write defprim write ' p-string? defprim string? ' p-vector? defprim vector? ' p-bv? defprim bytevector? diff --git a/prelude.scm b/prelude.scm index 849fe52..f647ed7 100644 --- a/prelude.scm +++ b/prelude.scm @@ -91,12 +91,13 @@ (define (bytevector-append . bs) (list->bytevector (apply append (map %bytevector->list bs)))) (define (utf8->string b) (list->string (map integer->char (%bytevector->list b)))) (define (string->utf8 s) (list->bytevector (map char->integer (string->list s)))) -(define (floor n) n) -(define (ceiling n) n) -(define (round n) n) -(define (truncate n) n) -(define (sqrt n) (if (< n 2) n (let loop ((x n)) (let ((y (quotient (+ x (quotient n x)) 2))) (if (>= y x) x (loop y)))))) -(define (exact-integer-sqrt n) (let ((s (sqrt n))) (list s (- n (* s s))))) +(define (floor x) (cond ((exact-integer? x) x) ((exact? x) (let ((n (numerator x)) (d (denominator x))) (if (>= n 0) (quotient n d) (- (quotient (+ (- n) d -1) d))))) (else (let ((t (%ftruncate x))) (if (> t x) (- t 1) t))))) +(define (ceiling x) (- (floor (- x)))) +(define (truncate x) (cond ((exact-integer? x) x) ((exact? x) (quotient (numerator x) (denominator x))) (else (%ftruncate x)))) +(define (round x) (let* ((f (floor x)) (diff (- x f))) (cond ((< diff 1/2) f) ((> diff 1/2) (+ f 1)) ((even? (exact f)) f) (else (+ f 1))))) +(define (%isqrt n) (if (< n 2) n (let loop ((x n)) (let ((y (quotient (+ x (quotient n x)) 2))) (if (>= y x) x (loop y)))))) +(define (sqrt x) (cond ((and (exact-integer? x) (>= x 0)) (let ((s (%isqrt x))) (if (= (* s s) x) s (%fsqrt x)))) ((and (exact? x) (>= x 0)) (let ((a (sqrt (numerator x))) (b (sqrt (denominator x)))) (if (and (exact? a) (exact? b)) (/ a b) (%fsqrt x)))) (else (%fsqrt x)))) +(define (exact-integer-sqrt n) (let ((s (%isqrt n))) (list s (- n (* s s))))) (define (%cicmp a b) (- (char->integer (char-foldcase a)) (char->integer (char-foldcase b)))) (define (char-ci=? . cs) (%chain %cicmp zero? cs)) (define (char-ci<? . cs) (%chain %cicmp negative? cs)) diff --git a/r7rs-tests.scm b/r7rs-tests.scm index 56fe448..fc9bd95 100644 --- a/r7rs-tests.scm +++ b/r7rs-tests.scm @@ -221,7 +221,7 @@ y ==> (a . 4) (vector->list (vector 1 2 3)) ==> (1 2 3) ; sqrt/floor on exact integers (sqrt 16) ==> 4 -(floor (sqrt 500)) ==> 22 +(floor (sqrt 500)) ==> 22.0 (floor 7) ==> 7 ; regression: a reported sieve program, a docstring body, vectors, do, when, named let (define (sieve-of-eratosthenes n) "Return list of primes up to n." (if (< n 2) '() (let ((marked (make-vector (+ n 1) #t))) (vector-set! marked 0 #f) (vector-set! marked 1 #f) (do ((i 2 (+ i 1))) ((> i (floor (sqrt n)))) (when (vector-ref marked i) (do ((j (* i i) (+ j i))) ((> j n)) (vector-set! marked j #f)))) (let loop ((i 2) (primes '())) (if (> i n) (reverse primes) (loop (+ i 1) (if (vector-ref marked i) (cons i primes) primes))))))) ==> sieve-of-eratosthenes @@ -324,3 +324,24 @@ y ==> (a . 4) (string->utf8 "AB") ==> #u8(65 66) (let loop ((i 0) (s "")) (if (< i 3000) (loop (+ i 1) (string-append "ab" "cd")) (string-length s))) ==> 4 (let ((v (make-vector 100 1))) (let loop ((i 0)) (if (< i 3000) (begin (make-string 10 #\a) (loop (+ i 1))))) (vector-ref v 99)) ==> 1 +; item 3: sqrt exact for exact squares, inexact otherwise; rounding on non-integers +(sqrt 1/4) ==> 1/2 +(sqrt 16.0) ==> 4.0 +(exact? (sqrt 2)) ==> #f +(< 1.4142 (sqrt 2) 1.4143) ==> #t +(floor -4.3) ==> -5.0 +(ceiling -4.3) ==> -4.0 +(truncate -4.3) ==> -4.0 +(round -4.3) ==> -4.0 +(floor 3.5) ==> 3.0 +(ceiling 3.5) ==> 4.0 +(truncate 3.5) ==> 3.0 +(round 3.5) ==> 4.0 +(round 2.5) ==> 2.0 +(round 7/2) ==> 4 +(round -7/2) ==> -4 +(round 7/10) ==> 1 +(floor -7/2) ==> -4 +(ceiling -7/2) ==> -3 +(truncate -7/2) ==> -3 +(floor 5) ==> 5 diff --git a/tests/r7rs/results.txt b/tests/r7rs/results.txt index e0a7fd4..912484d 100644 --- a/tests/r7rs/results.txt +++ b/tests/r7rs/results.txt @@ -1,4 +1,4 @@ -r7rs suite: 486 passed, 123 failed, 523 skipped, 1132 total +r7rs suite: 500 passed, 109 failed, 523 skipped, 1132 total setup forms skipped: 48 skipped tests by reason: @@ -72,30 +72,6 @@ failures: => not a number [6.2 Numbers] (test 288.0 (lcm 32.0 -36)) => not a number -[6.2 Numbers] (test -5.0 (floor -4.3)) - => <<fail -4.3>> -[6.2 Numbers] (test -4.0 (ceiling -4.3)) - => <<fail -4.3>> -[6.2 Numbers] (test -4.0 (truncate -4.3)) - => <<fail -4.3>> -[6.2 Numbers] (test -4.0 (round -4.3)) - => <<fail -4.3>> -[6.2 Numbers] (test 3.0 (floor 3.5)) - => <<fail 3.5>> -[6.2 Numbers] (test 4.0 (ceiling 3.5)) - => <<fail 3.5>> -[6.2 Numbers] (test 3.0 (truncate 3.5)) - => <<fail 3.5>> -[6.2 Numbers] (test 4.0 (round 3.5)) - => <<fail 3.5>> -[6.2 Numbers] (test 4 (round 7/2)) - => <<fail 7/2>> -[6.2 Numbers] (test 1 (round 7/10)) - => <<fail 7/10>> -[6.2 Numbers] (test -4 (round -7/2)) - => <<fail -7/2>> -[6.2 Numbers] (test -1 (round -7/10)) - => <<fail -7/10>> [6.2 Numbers] (test 1/3 (rationalize (exact .3) 1/10)) => unbound variable: rationalize [6.2 Numbers] (test 1.0 (inexact (exp 0))) @@ -152,8 +128,6 @@ failures: => unbound variable: atan [6.2 Numbers] (test -0.785398163397448 (atan -1.0 1.0)) => unbound variable: atan -[6.2 Numbers] (test 1.4142135623731 (sqrt 2)) - => <<fail 1>> [6.2 Numbers] (test 27 (expt 3 3)) => unbound variable: expt [6.2 Numbers] (test 1 (expt 0 0)) @@ -172,8 +146,6 @@ failures: => too many arguments [6.3 Booleans] (test #f (boolean=? #t #t #f)) => too many arguments -[6.4 Lists] (test 'c (list-ref '(a b c d) (exact (round 1.8)))) - => not a pair [6.4 Lists] (test '(0 ("Sue" "Sue") "Anna") (let ((lst (list 0 '(2 2 2 2) "Anna"))) (list-set! lst 1 '("Sue" "Sue")) lst)) => unbound variable: list-set! [6.4 Lists] (test '("b" "c") (member "B" '("a" "b" "c") string-ci=?))