diff options
Diffstat (limited to 's7test.scm')
| -rw-r--r-- | s7test.scm | 602 |
1 files changed, 592 insertions, 10 deletions
@@ -3679,6 +3679,11 @@ void block_init(s7_scheme *sc) ;;; move these! (let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (quotient i 3)))) (num-test (fc) (quotient 9 3))) +(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (ash 3 3)))) (num-test (fc) (ash 3 3))) +(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (ash 3 i)))) (num-test (fc) (ash 3 9))) +(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (ash 3 (+ i 1))))) (num-test (fc) (ash 3 10))) +(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (ash i (+ i 1))))) (num-test (fc) (ash 9 10))) +(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (ash (+ i 1) (- i 1))))) (num-test (fc) (ash 10 8))) (let () (define (fc) (do ((count 0) (j 3) (i 0 (+ i 1))) ((= i 10) count) (set! count (quotient i j)))) (num-test (fc) (quotient 9 3))) (let () (define (fc) (do ((count 0.0) (i 0.0 (+ i 1.0))) ((>= i 10.0) count) (set! count (quotient i 3.0)))) (num-test (fc) (quotient 9.0 3.0))) (let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (remainder i 3)))) (test (fc) (remainder 9 3))) @@ -3869,6 +3874,209 @@ void block_init(s7_scheme *sc) (let ((str #u(1 2 3))) (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 1) count) (set! count (byte-vector-ref str i)))) (test (fc) 1)) ; byte_vector_ref_i (let ((str #u(1 2 3))) (define (fc) (do ((i 0 (+ i 1))) ((= i 1) (str 0)) (byte-vector-set! str i 4))) (test (fc) 4)) ; byte_vector_set_i +(let () (define (f1) (let ((dfn #f)) (do ((count 0) (i 0 (+ i 1))) ((= i 1) dfn) (if (logbit? i count) (set! dfn #t))))) (test (f1) #f)) ; opt_b_ii_ss +(let () (define (f2) (let ((dfn #f)) (do ((i 0 (+ i 1))) ((= i 1) dfn) (if (logbit? i 0) (set! dfn #t))))) (test (f2) #f)) ; opt_b_ii_sc_bit +(let () (define (f3) (let ((dfn #f)) (do ((count 0.0) (i 0.0 (+ i 1.0))) ((= i 1.0) dfn) (if (> i count) (set! dfn #t))))) (test (f3) #f)) ; opt_b_dd_ss_gt +(let () (define (f4) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((= i 1.0) dfn) (if (< i count) (set! dfn #t))))) (test (f4) #t)) ; opt_b_dd_ss_lt +(let () (define (f5) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((= i 1.0) dfn) (if (< i 1.0) (set! dfn #t))))) (test (f5) #t)) ; opt_b_dd_sc_lt +(let () (define (f6) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((= i 1.0) dfn) (if (>= i 0.0) (set! dfn #t))))) (test (f6) #t)) ; opt_b_dd_sc_geq +(let () (define (f7) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((= i 1.0) dfn) (if (<= i 1.0) (set! dfn #t))))) (test (f7) #t)) ; opt_b_dd_sc +(let () (define (f8) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((>= i 1.0) dfn) (if (= i 1.0) (set! dfn #t))))) (test (f8) #f)) ; opt_b_dd_sc_eq +(let () (define (f9) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((>= i 1.0) dfn) (if (= i (+ count 1.0)) (set! dfn #t))))) (test (f9) #f)) ; opt_b_dd_sf +(let () (define (f10) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((>= i 1.0) dfn) (if (= (+ i 1.0) (+ count 1.0)) (set! dfn #t))))) (test (f10) #f)) ; opt_b_dd_ff +(let () (define (f11) (do ((x 1.0) (i 0 (+ i 1))) ((= i 1)) (if (negative? (+ x 1.0)) (* x 2) (- x 3)))) (test (f11) #t)) ; opt_b_d_f +(let () (define (f12) (let ((dfn #\c)) (do ((i 0 (+ i 1))) ((= i 1) dfn) (if (char=? dfn #\a) (set! dfn #\b))))) (test (f12) #\c)) ; opt_b_7pp_sc +(let () (define (f13) (let ((dfn #\c)) (do ((i 0 (+ i 1))) ((= i 1) dfn) (if (eq? dfn #\a) (set! dfn #\b))))) (test (f13) #\c)) ; opt_b_pp_sc + +(define _gfx_ 3) +(define _vfx_ (vector (vector 0))) +(define _vfxi_ (vector 0)) +(let () ; fx_* coverage + (define (f1 x) (and (pair? (cddr x)) (symbol? (cadr x)))) + (test (f1 (list 1 2 3)) #f) + (test (f1 (list 1 'a 3)) #t) + (test (f1 (list 1 'a)) #f) + + (define (f2 x) (and (not (null? x)) (pair? (car x)))) + (test (f2 (list 1 2)) #f) + (test (f2 (list (list 1) 2)) #t) + (test (f2 (list)) #f) + + (define (f3 x y) (or (< x y) (<= x y))) + (test (f3 3 2) #f) + (test (f3 3 3) #t) + (test (f3 1 2) #t) + + (define (f4 x y) (or (>= x y) (> x _gfx_))) + (test (f4 4 5) #t) + (test (f4 3 3) #t) + (test (f4 2 3) #f) + + (define (f5 fv z) (let ((x (vector-ref fv 0))) (when (< x z) (vector-set! fv 0 (+ x 1)) (f5 fv z)))) + (test (f5 (vector 0) 2) #<unspecified>) + + (define (f6 fv z) (let ((x (length fv))) (when (eqv? x z) (f6 (cons x fv) z)))) + (test (f6 (list 0) 2) #<unspecified>) + + (define (f7 x y) (let ((z x)) (if (zero? z) (f7 (- x 1) (cons z y))))) + (test (f7 2 ()) #<unspecified>) + + (define (f8 x y z) (or (proper-list? z) (hash-table? x) (integer? z))) + (test (f8 0 0 (list 1)) #t) + (test (f8 0 0 1) #t) + (test (f8 0 0 (vector 1)) #f) + + (define (f9 x y) (or (vector? x) (not x) (vector? y))) + (test (f9 #f 0) #t) + (test (f9 #(0) 0) #t) + (test (f9 () ()) #f) + + (define (f10 x) (or (= x _gfx_) (eqv? x _gfx_))) + (test (f10 1) #f) + (test (f10 _gfx_) #t) + + (define (f11 x y z) (or (not (eq? (car z) 'a)) (null? (cddr z)) (eqv? x y))) + (test (f11 1 2 (list 1 2)) #t) + (test (f11 1 1 (list 'a 2)) #t) + + (define (f12 x y) (if (not (> y x)) (not (eqv? y x)))) + (test (f12 1 2) #<unspecified>) + (test (f12 1 1) #f) + + (define (f13 x y q r) (if (zero? (- (* q r) (* r q))) 32 12) (if (< (- q r) (- r q)) 32 12)) + (test (f13 1 2 3 4) 32) + + (define (f14 x y) (let ((z (+ x y))) (cond ((= z 0) pi) ((< z 0) 'oops) (else (f14 (- x 1) (- y 1)))))) + (test (f14 1 2) 'oops) + + (define (f15 lst) (let loop ((p lst) (sum 0)) (if (null? p) sum (loop (cdr p) (+ sum (car p)))))) + (test (f15 (list 0 1 2)) 3) + + (define (f16 x y z) (+ (* 3.0 x) (- 3.0 x) (- z 3.0))) + (test (f16 3 4 5) 11.0) + + (define (f17 x y z) (let ((v (vector 'a))) (if (eq? z (vector-ref v x)) 0 1))) + (test (f17 0 0 'a) 0) + + (define (f18 x y z) (let ((v (vector 0))) (if (>= z (vector-ref v x)) 0 1))) + (test (f18 0 0 0) 0) + + (define (f19 x y z) (let ((v (vector 0))) (if (> (vector-ref v x) z) 0 1))) + (test (f19 0 0 0) 1) + + (define (f20 x y z) (let ((v (vector 0))) (+ (* z (vector-ref v x)) (- z (vector-ref v y))))) + (test (f20 0 0 0) 0) + + (define (f21 x y z) (let ((v (vector 0))) (if (> (+ z (vector-ref v x)) 1) 0 1))) + (test (f21 0 0 0) 1) + + (define (len=2? x) (and (pair? x) (pair? (cdr x)) (null? (cddr x)))) + (define (f22 x) (and (list? x) (len=2? x))) + (test (f22 (list 1 2)) #t) + + (define (len>2? x) (and (pair? x) (pair? (cdr x)) (pair? (cddr x)))) + (define (f23 x) (and (list? x) (len>2? x))) + (test (f23 (list 1 2 3)) #t) + + (define (f24 x) (let ((h (hash-table))) (hash-table-set! h x (+ (or (hash-table-ref h x) 0) 1)))) + (test (f24 'a) 1) + + (define (f25 x) (if (or (not (symbol? x)) (keyword? x)) 1 0)) + (test (f25 'a) 0) + (test (f25 :a) 1) + (test (f25 #f) 1) + + (define (f26 x) (if (> (+ _gfx_ (* x 2) 32) 0) 1 0)) + (test (f26 3) 1) + + (define (f27 x) (let ((y 3)) (if (zero? (remainder x y)) 0 1))) + (test (f27 4) 1) + (test (f27 6) 0) + + (define (f28 x y) (if (= (remainder (car y) x) 0) 0 (f28 (- x 1) y))) + (test (f28 2 '(3)) 0) + (test (f28 3 '(3)) 0) + + (define (f29) (let ((v (vector 1 2)) (i 0) (j 1)) (if (zero? (- (vector-ref v i) (vector-ref v j))) 0 1))) + (test (f29) 1) + + (define (f30 x) (if (eq? (string-ref (symbol->string (car x)) 0) #\a) 0 1)) + (test (f30 '(abc)) 0) + (test (f30 '(bcd)) 1) + + (define (f31 x) (do ((y 3 (+ y 1))) ((or (zero? x) (>= y x)) 0))) + (test (f31 4) 0) + (test (f31 0) 0) + + (define (f32 x y z) (if (vector-ref x (+ y z)) 1 0)) + (test (f32 (vector #f #t) 1 0) 1) + + (define (f33 x y) (if (string? (number->string (+ 1 (car x) (car x)) y)) 1 0)) + (test (f33 '(0) 10) 1) + + (define (f34 x y q r) (eqv? (vector-ref (vector-ref q r) y) 0)) + (test (f34 0 0 (vector (vector 1)) 0) #f) + (test (f34 0 0 (vector (vector 0)) 0) #t) + + (define (f35 x y q r) (eqv? (vector-ref (vector-ref x y) q) 0)) + (test (f35 (vector (vector 1)) 0 0 0) #f) + (test (f35 (vector (vector 0)) 0 0 0) #t) + + (define (f36 x y) (eqv? (vector-ref (vector-ref _vfx_ y) x) 0)) + (test (f36 0 0) #t) + (test (f36 0 1) 'error) + + (define (f37 x) (eqv? (vector-ref _vfx_ (vector-ref _vfxi_ x)) 0)) + (test (f37 0) #f) + + (define (f38 x y) (eqv? (+ (* x x) (* y y)) 1)) + (test (f38 1 2) #f) + (test (f38 1 0) #t) + + (define (f39 x y z) (eqv? (vector-ref (vector-ref x y) z) 0)) + (test (f39 (vector (vector 0)) 0 0) #t) + (test (f39 (vector (vector 1)) 0 0) #f) + + (define (f40 items sequence) + (cond ((not (pair? sequence)) sequence) ((memq (car sequence) items) (f40 items (cdr sequence))) (else (cons (car sequence) (f40 items (cdr sequence)))))) + (test (f40 '(a b c) '(a d f e b c)) '(d f e)) + + (define (f41 row dist placed) (or (null? placed) (and (not (= (car placed) (+ row dist))) (not (= (car placed) (- row dist))) (f41 row (+ dist 1) (cdr placed))))) + (test (f41 0 0 '(0 1 2)) #f) + (test (f41 0 1 '(0 1 2)) #t) + + (define (f42 v i j y) + (if (and (or (> (vector-ref v i) y) + (>= y (vector-ref v j))) + (or (> (vector-ref v j) y) + (>= y (vector-ref v i)))) + 0 1)) + (test (f42 (vector 1 2 3 4) 1 2 3) 0) + (test (f42 (vector 1 2 3 4) 1 2 2) 1) + + (define-constant (f43 x) + (and (pair? x) (pair? (cdr x)))) + (define (g) + (let ((x (list 1 2))) + (if (f43 x) 0 1))) + (test (g) 0) + + (define (f44 fv z) + (let ((x (vector-ref fv 0))) + (when (< x 30) + (vector-set! fv 0 z) + (f44 fv (+ z 1))))) + (test (f44 (vector 0) 0) #<unspecified>) + + (define (f45 x y z q) + (zero? (* x (hash-table-ref y (vector-ref z q))))) + (test (f45 2.0 (hash-table 'a 3.0) (vector 'a) 0) #f) + + (define (f46 x y z) + (zero? (- (string->number (vector-ref x y)) z))) + (test (f46 (vector "3.0") 0 1.0) #f) +) + ;;; -------------------------------------------------------------------------------- ;;; type-of @@ -10064,6 +10272,8 @@ i" (lambda (p) (eval (read p)))) pi) (test (append (string->byte-vector "asdasd") '("asd")) 'error) (test (append (string->byte-vector "asdasd") #("asd")) 'error) +(test (append (inlet) (hash-table :readable 123)) 'error) + (test (let ((h1 (hash-table 'a 1 'b 2)) (h2 (hash-table 'c 3))) (append h1 h2)) (hash-table 'c 3 'a 1 'b 2)) (test (let ((i1 (inlet 'a 1)) (i2 (inlet 'b 2 'c 3))) (append i1 i2)) (inlet 'a 1 'c 3 'b 2)) (test (let ((s1 "abc") (s2 "def")) (append s1 s2)) "abcdef") @@ -11258,6 +11468,12 @@ i" (lambda (p) (eval (read p)))) pi) (set! sum (+ sum (iv (- (+ i 1) 1) (+ i 1))))))) (test (g) 2)) +(let ((iv (make-int-vector (list 2 3) 1)) ; optimizer bug + (c 3)) + (define (f1) (let ((v (vector #f))) (do ((i 0 (+ i 1))) ((= i 1) (vector-ref v 0)) (vector-set! v 0 (int-vector-set! iv 0 0 c))))) + (define (f2) (let ((v (vector #f))) (do ((i 0 (+ i 1))) ((= i 1) (vector-ref v 0)) (vector-set! v 0 (int-vector-set! iv 0 0 3))))) + (test (f1) 3) + (test (f2) 3)) ;;; -------------------------------------------------------------------------------- @@ -20428,6 +20644,11 @@ a2" 3) "132") (test (equal? '`#() ''#()) #f) ; it equals #() -- this is consistent -- see below (test (equal? '`#() ``#()) #t) +(test (catch #t (lambda () (with-input-from-string "#0d()" read)) (lambda (type info) (apply format #f info))) + "#nD(...) dimensions argument 1, 0, is out of range (must be 1 or more)") +(test (catch #t (lambda () (with-input-from-string "#1230d()" read)) (lambda (type info) (apply format #f info))) + "reading #1230...: 1230 is too large, (*s7* 'max-vector-dimensions): 512") + (test (equal? '() '()) #t) (test (equal? (quote ()) '()) #t) (test (equal? '() (quote ())) #t) @@ -21449,7 +21670,8 @@ c" (test (object->string (inlet 'a (let ((b 1)) (lambda () (+ b c)))) :readable) "(inlet :a (let ((b 1)) (lambda () (+ b c))))") (test (object->string (inlet 'a (let ((b 1)) (lambda () (+ b pi)))) :readable) "(inlet :a (let ((b 1)) (lambda () (+ b pi))))") (test (object->string (let* ((a 1) (b a)) (curlet)) :readable) - "(sublet (sublet (sublet (inlet :ok #t)) :a 1) :b 1)") + ;; "(sublet (sublet (sublet (inlet :ok #t)) :a 1) :b 1)" + "(sublet (sublet (inlet :ok #t)) :a 1 :b 1)") ; depends on op_let_star1 (test (object->string (let ((a 1)) (define (b c) (+ c a)) (curlet)) :readable) "(sublet (sublet (inlet :ok #t)) :a 1 :b (let ((a 1)) (lambda (c) (+ c a))))"))) @@ -25233,6 +25455,10 @@ in s7: (define (dot) (do ((i 0 (+ i 1)) (j 3)) ((or (< i 0) (end i))))) (dot) (test y 3)) +(let () + (define (f1) (eval '(do ((i 0 j) (j 0 (+ j 1))) ((= j 3) i)))) + (define (g) (catch #t f1 (lambda args #f))) + (test (g) 2)) (test (let ((lst '(1 2 3)) (v (vector 0 0 0))) @@ -25681,7 +25907,179 @@ in s7: (k 0 (+ k 1))) ((= k 8) (set! sum (+ sum lsum))) (set! lsum (+ lsum k))))) - (test (h4) 140)) + (test (h4) 140) + + (define (f1) + (let ((sum #i(0))) + (do ((i 0 (+ i 1))) + ((= i 10) sum) + (case (remainder i 3) + ((0) (int-vector-set! sum 0 (+ (int-vector-ref sum 0) 1))) + ((1) (int-vector-set! sum 0 (+ (int-vector-ref sum 0) 2))) + (else (int-vector-set! sum 0 (+ (int-vector-ref sum 0) 3))))))) + (test (f1) #i(19)) + + (define (f2) + (let ((sum 0)) + (do ((i 0 (+ i 1))) + ((= i 10) sum) + (case (remainder i 3) + ((0) (set! sum (+ sum 1))) + ((1) (set! sum (+ sum 2))) + (else (set! sum (+ sum 3))))))) ; 19 + (test (f2) 19) + + (define (f3) + (let ((sum 0)) + (do ((i 0 (+ i 1))) + ((= i 10) sum) + (case (remainder i 3) + ((0) (set! sum (+ sum 2)) (set! sum (- sum 1))) + ((1) (set! sum (+ sum 2))) + (else (set! sum (+ sum 3))))))) ; 19 + (test (f3) 19) + + (define (f4) + (let ((sum 0)) + (do ((i 0 (+ i 1))) + ((= i 10) sum) + (case (remainder i 3) + ((0) (set! sum (+ sum 1))) + ((1) (set! sum (+ sum 2))) + ((3) (set! sum (+ sum 3))))))) ; 10 + (test (f4) 10) + + (define (f41) + (let ((sum 0)) + (do ((i 0 (+ i 1))) + ((= i 10) sum) + (case (remainder i 3) + ((0) (set! sum (+ sum 1))) + ((1) (set! sum (+ sum 2))) + ((2) (set! sum (+ sum 3))))))) ; 19 + (test (f41) 19) + + (define (f5) + (let ((res 0)) + (do ((i 0 (+ i 1))) + ((= i 10) res) + (case i + ((0 1 2 3 4 5 6) (set! res 1)) + ((7 8 9) (set! res 123)))))) ; 123 + (test (f5) 123) + + (define (f6) + (let ((res 0)) + (do ((i 0 (+ i 1))) + ((= i 10) res) + (set! res (case i + ((0 1 2 3 4 5 6) 1) + ((7 8 9) 2)))))) ; 2 + (test (f6) 2) + + (define (f7) + (let ((res 0)) + (do ((i 0 (+ i 1))) + ((= i 10) res) + (set! res (case i + ((0 1 2 3 4 5 6) 1) + ((7 8) 2)))))) ; #<unspecified> + (test (f7) #<unspecified>) + + (define (f8) + (let ((res 0)) + (do ((i 0 (+ i 1))) + ((= i 10) res) + (set! res (+ (case i + ((0 1 2 3 4 5 6) 1) + (else 2)) + 123))))) ; 125 + (test (f8) 125) + + (let () ; opt_cond_1 + (define (cd1) + (let ((v (make-vector 6 #f))) + (do ((i 0 (+ i 1))) + ((= i 6) v) + (vector-set! v i (cond ((< i 3) (+ i 10))))))) + (test (cd1) #(10 11 12 #<unspecified> #<unspecified> #<unspecified>)) + + (define (cd2 x) ; opt_cond_2 + (let ((y 0) + (z 1.0)) + (do ((i 0 (+ i 1))) + ((= i 3) y) + (cond ((= x z) + (set! y (+ y 1))) + (else 3))))) + (test (cd2 1.0) 3) + (test (cd2 0.0) 0) + + (define (cd3) ; opt_cond + (let ((v (make-vector 6 #f))) + (do ((i 0 (+ i 1))) + ((= i 6) v) + (vector-set! v i (cond ((< i 3) + (+ i 10)) + ((>= i 3) + (- i 10))))))) + (test (cd3) #(10 11 12 -7 -6 -5)) + + (define (cd4) ; opt_cond + (let ((v (make-vector 6 #f))) + (do ((i 0 (+ i 1))) + ((= i 6) v) + (vector-set! v i (cond ((< i 2) + (+ i 10)) + ((= i 2) + 123) + ((> i 3) + (- i 10))))))) + (test (cd4) #(10 11 123 #<unspecified> -6 -5))) + + (define (do1) + (let ((v (make-int-vector 10))) + (do ((k 0 (+ k 1))) + ((= k 1) + (int-vector-ref v 0)) + (do ((i 0 (+ i 1)) + (j 0 (+ j 2))) + ((= i 10) + (set! j (* j 2)) + (int-vector-set! v 0 (+ i j))) + (int-vector-set! v 1 1) + (int-vector-set! v 0 0))))) + (test (do1) 50) + + (define (do2) + (let ((v (make-int-vector 10))) + (do ((k 0 (+ k 1))) + ((= k 1) + (int-vector-ref v 0)) + (do ((i 0 (+ i 1)) + (j 0 (+ j 2)) + (z 32)) + ((= i 10) + (set! j (* j 2)) + (int-vector-set! v 0 (+ i j z))) + (int-vector-set! v 1 1) + (int-vector-set! v 0 0))))) + (test (do2) 82) + + (define (do3) + (let ((v (make-int-vector 10))) + (do ((k 0 (+ k 1))) + ((= k 1) + (int-vector-ref v 0)) + (do ((i 0 (+ i 1)) + (z 32) + (j 0 (+ j 2))) + ((= i 10) + (set! j (* j 2)) + (int-vector-set! v 0 (+ i j z))) + (int-vector-set! v 1 1) + (int-vector-set! v 0 0))))) + (test (do3) 82)) (let () (define (fdo5) (do ((si () '())) ((null? si) 'mi))) (test (fdo5) 'mi)) (let () (define (fdo5) (do ((si '() '())) ((null? si) 'mi))) (test (fdo5) 'mi)) @@ -27534,6 +27932,18 @@ in s7: (define (fx-tc-if-a-laa-z x y) (if (> x 0) (fx-tc-if-a-laa-z (- x 1) (+ y 1)) y)) (test (let ((z 10)) (define (ftc-2 x) (+ x (fx-tc-if-a-laa-z 10 0))) (ftc-2 z)) 20) + ;; -------- OP_TC_IF_A_Z_L3A -------- + (define (tc-if-a-z-l3a-1 x y z) (if (null? x) (begin (vector-set! y 0 (+ z 32)) y) (tc-if-a-z-l3a-1 (cdr x) y (+ z 1)))) + (test (tc-if-a-z-l3a-1 '(1 2 3) #(1 2 3) 1) #(36 2 3)) + + ;; -------- OP_TC_IF_A_L3A_Z -------- + (define (tc-if-a-l3a-z-1 x y z) (if (pair? x) (tc-if-a-l3a-z-1 (cdr x) y (+ z 1)) (begin (vector-set! y 0 (+ z 32)) y))) + (test (tc-if-a-l3a-z-1 '(1 2 3) #(1 2 3) 1) #(36 2 3)) + + ;; -------- OP_TC_IF_A_Z_IF_A_L3A_L3A -------- + (define (l3a x y z) (if (> x y) z (if (< y z) (l3a x y (- z 1)) (l3a x (- y 1) z)))) + (test (l3a 0 10 10) 0) + ;; -------- OP_TC_IF_A_Z_LA -------- (define (tc-if-a-z-la-1 x) (if (zero? x) 3 (tc-if-a-z-la-1 (- x 1)))) (test (tc-if-a-z-la-1 10) 3) @@ -27586,6 +27996,26 @@ in s7: (define (tc-if-a-z-if-a-z-la-6 x) (if (zero? (modulo x 7)) (- x 7) (if (negative? (modulo x 5)) (* x 2) (tc-if-a-z-if-a-z-la-6 (+ x 1))))) (test (tc-if-a-z-if-a-z-la-6 22) 21) + ;; -------- OP_TC_COND_A_Z_A_Z_LA -------- + (define (tc-cond-a-z-a-z-la-1 x) (cond ((zero? (modulo x 7)) x) ((zero? (modulo x 5)) x) (else (tc-cond-a-z-a-z-la-1 (+ x 1))))) + (test (tc-cond-a-z-a-z-la-1 22) 25) + (test (tc-cond-a-z-a-z-la-1 6) 7) + + (define (tc-cond-a-z-a-z-la-2 x) (cond ((zero? (modulo x 7)) x) ((zero? (modulo x 5)) x) (else (tc-cond-a-z-a-z-la-2)))) + (test (tc-cond-a-z-a-z-la-2 22) 'error) + + (define (tc-cond-a-z-a-z-la-3 x) (cond ((zero? (modulo x 7)) x) ((zero? (modulo x 5)) x) (else (tc-cond-a-z-a-z-la-3 x x)))) + (test (tc-cond-a-z-a-z-la-3 22) 'error) + + (define (tc-cond-a-z-a-z-la-4 x) (cond ((zero? (modulo x 7)) (set! x (* 2 x)) x) ((zero? (modulo x 5)) x) (else (tc-cond-a-z-a-z-la-4 (+ x 1))))) + (test (tc-cond-a-z-a-z-la-4 6) 14) + + (define (tc-cond-a-z-a-z-la-5 x) (cond ((zero? (modulo x 7)) x) ((zero? (modulo x 5)) (let ((z (* 2 x))) z)) (else (tc-cond-a-z-a-z-la-5 (+ x 1))))) + (test (tc-cond-a-z-a-z-la-5 22) 50) + + (define (tc-cond-a-z-a-z-la-6 x) (cond ((zero? (modulo x 7)) (- x 7)) ((negative? (modulo x 5)) (* x 2)) (#t (tc-cond-a-z-a-z-la-6 (+ x 1))))) + (test (tc-cond-a-z-a-z-la-6 22) 21) + ;; -------- OP_TC_IF_A_Z_IF_A_LA_Z -------- (define (tc-if-a-z-if-a-la-z-1 x) (if (zero? (modulo x 7)) x (if (positive? (modulo x 5)) (tc-if-a-z-if-a-la-z-1 (+ x 1)) x))) (test (tc-if-a-z-if-a-la-z-1 22) 25) @@ -27672,6 +28102,20 @@ in s7: (define (tc-and-a-or-a-la-5 x) (and (positive? x) (or (= x 10) (tc-and-a-or-a-la-5 x x)))) (test (tc-and-a-or-a-la-5 9) 'error) + + ;; -------- OP_TC_AND_A_OR_A_A_LA -------- + (define (tc-and-a-or-a-a-la-1 x) (and (positive? x) (or (= x 10) (= x 9) (tc-and-a-or-a-a-la-1 (+ x 1))))) + (test (tc-and-a-or-a-a-la-1 1) #t) + (test (tc-and-a-or-a-a-la-1 -1) #f) + + (define (tc-and-a-or-a-a-la-3 x) (and (positive? x) (or (= x 10) (= x 9) (tc-and-a-or-a-a-la-3 (- x 1))))) + (test (tc-and-a-or-a-a-la-3 8) #f) + + (define (tc-and-a-or-a-a-la-4 x) (and (positive? x) (or (= x 10) (= x 9) (tc-and-a-or-a-a-la-4)))) + (test (tc-and-a-or-a-a-la-4 8) 'error) + + (define (tc-and-a-or-a-a-la-5 x) (and (positive? x) (or (= x 10) (= x 9) (tc-and-a-or-a-a-la-5 x x)))) + (test (tc-and-a-or-a-a-la-5 8) 'error) ;; -------- OP_TC_OR_A_AND_A_LA -------- (define (tc-or-a-and-a-la-1 x) (or (null? x) (and (integer? (car x)) (tc-or-a-and-a-la-1 (cdr x))))) @@ -27899,6 +28343,21 @@ in s7: (define (recur-if-a-a-opa-laaq-4 x y) (if (= x 0) (call-with-exit (lambda (cc) y)) (+ 1 (recur-if-a-a-opa-laaq-4 (- x 1) (+ y 1))))) (test (recur-if-a-a-opa-laaq-4 10 0) 20) + + ;; -------- OP_RECUR_IF_A_A_opA_L3Aq -------- + (define (recur-if-a-a-opa-l3aq-1 x y z) (if (= x 0) y (+ 1 (recur-if-a-a-opa-l3aq-1 (- x 1) (+ y z) (+ z 1))))) + (test (recur-if-a-a-opa-l3aq-1 10 0 0) 55) ; z by 1 = 110/2 + + (define (recur-if-a-a-opa-l3aq-2 x y z) (if (= x 0) y (+ 1 (recur-if-a-a-opa-l3aq-2)))) + (test (recur-if-a-a-opa-l3aq-2 10 0 0) 'error) + + (define (recur-if-a-a-opa-l3aq-3 x y z) (if (= x 0) y (+ 1 (recur-if-a-a-opa-l3aq-3 (- x 1) (+ y 1) 2 1)))) + (test (recur-if-a-a-opa-l3aq-3 10 0 0) 'error) + + (define (wf3 lst i val) (if (= i 0) (cons val (cdr lst)) (cons (car lst) (wf3 (cdr lst) (- i 1) val)))) + (test (wf3 (list 1 2 3 4) 3 5) '(1 2 3 5)) + (test (wf3 (list 1 2 3 4) 2 5) '(1 2 5 4)) + (test (wf3 (list 1 2 3 4) 1 5) '(1 5 3 4)) ;; -------- OP_RECUR_IF_A_A_opLA_LAq -------- (define (recur-if-a-a-opla-laq-1 x) (if (< x 2) x (+ (recur-if-a-a-opla-laq-1 (- x 1)) (recur-if-a-a-opla-laq-1 (- x 2))))) @@ -28250,12 +28709,58 @@ in s7: (define (tak-3 x y z) (if (not (< y x)) z (tak-3 (tak-3 (- x 1) y z) (tak-3 (- y 1) z x) (tak-3 (- z 1) x y) x))) (test (tak-3 10 5 1) 'error) + (define (dly0 x y) (if (zero? x) y (dly0 (- x 1) (+ x y)))) + (test (dly0 10 1)56) + + (define (dly1 x y) (if (null? x) y (dly1 (cdr x) (cons (car x) y)))) + (test (dly1 '(10 9 8 7 6 5 4 3 2 1 0) ()) '(0 1 2 3 4 5 6 7 8 9 10)) + + (define (dly2 x y) (and (list? x) (or (and (null? x) y) (dly2 (cdr x) (cons (car x) y))))) + (test (dly2 '(10 9 8 7 6 5 4 3 2 1 0) ()) '(0 1 2 3 4 5 6 7 8 9 10)) + + (define (dly3 x y) (or (and (null? x) y) (and (pair? x) (dly3 (cdr x) (cons (car x) y))))) + (test (dly3 '(10 9 8 7 6 5 4 3 2 1 0) ()) '(0 1 2 3 4 5 6 7 8 9 10)) ) (when (provided? 'debugging) (report-missed-calls)) ;;; end optimizer stuff +;;; coverage tests for closure_3p +(let () + (define (byte siz pos) (list pos siz)) + (define (dpb integer bytespec into) (list integer bytespec into)) + (define (lpb x integer bytespec into) (let ((v (list-values 0 integer bytespec into))) (set! (v 0) x) v)) + (define (mpb x y) (values x y)) + (define (mpb1 x) (values x)) + + (define (g) + (test (dpb 1 2 3) '(1 2 3)) + (test (dpb 1 2 (byte 4 5)) '(1 2 (5 4))) + (test (dpb 1 (byte 4 5) 3) '(1 (5 4) 3)) + (test (dpb (byte 4 5) 2 3) '((5 4) 2 3)) + (test (dpb 1 (byte 4 5) (byte 6 7)) '(1 (5 4) (7 6))) + (test (dpb (byte 4 5) (byte 6 7) 3) '((5 4) (7 6) 3)) + (test (dpb (byte 4 5) 2 (byte 6 7)) '((5 4) 2 (7 6))) + (test (dpb (byte 4 5) (byte 6 7) (byte 8 9)) '((5 4) (7 6) (9 8))) + + (test (lpb -1 1 2 3) '(-1 1 2 3)) + (test (lpb -1 1 2 (byte 4 5)) '(-1 1 2 (5 4))) + (test (lpb -1 1 (byte 4 5) 3) '(-1 1 (5 4) 3)) + (test (lpb -1 (byte 4 5) 2 3) '(-1 (5 4) 2 3)) + (test (lpb -1 1 (byte 4 5) (byte 6 7)) '(-1 1 (5 4) (7 6))) + (test (lpb -1 (byte 4 5) (byte 6 7) 3) '(-1 (5 4) (7 6) 3)) + (test (lpb -1 (byte 4 5) 2 (byte 6 7)) '(-1 (5 4) 2 (7 6))) + (test (lpb -1 (byte 4 5) (byte 6 7) (byte 8 9)) '(-1 (5 4) (7 6) (9 8))) + + (test (dpb (mpb 1 2) 3 4) 'error) + (test (dpb 1 2 (mpb 1 2)) 'error) + (test (dpb 1 (mpb 1 2) 3) 'error) + (test (dpb (mpb1 1) 3 4) '(1 3 4)) + (test (dpb 1 2 (mpb1 3)) '(1 2 3)) + (test (dpb 1 (mpb1 2) 3) '(1 2 3))) + (g)) + ;;; -------------------------------------------------------------------------------- ;;; begin @@ -30519,6 +31024,11 @@ in s7: (test (let ((a #<eof>)) (eof-object? a)) #t) (test (let ((a #<unspecified>)) (eq? a #<unspecified>)) #t) (test (let* ((x 1) (x (+ x 1))) x) 2) ; ?? +(test (object->string (let* ((a 1) (e (curlet)) (b (+ a 1))) e)) "(inlet 'a 1)") +(let () + (define (f) (let* ((a 1) (e (curlet)) (b (+ a 1))) e)) + (define (g) (do ((v (vector #f)) (i 0 (+ i 1))) ((= i 1) (v 0)) (vector-set! v 0 (f)))) + (test (object->string (g)) "(inlet 'a 1)")) (test (let _name_ ((x 1) (y (_name_ 2))) (+ x y)) 'error) (test (let* _name_ ((x 1) (y (_name_ 2))) (+ x y)) 'error) @@ -32025,6 +32535,17 @@ in s7: count) 2) +(let ((continuations ())) ; chicken mailing list + (define (push arg) + (set! continuations (cons arg continuations))) + (define (capture-from-map arg) + (call-with-current-continuation + (lambda (cc) + (push cc) + arg))) + (define numbers (map capture-from-map '(1 2 3))) + (test numbers '(1 2 3))) + (let ((c #f) (vals ())) (let ((val (+ 1 2 (call/cc (lambda (r) (set! c r) (r 3)))))) @@ -35572,19 +36093,23 @@ who says the continuation has to restart the map from the top? (set! x y) (set! y (cdr (v (+ i 1)))))))) -;;; closure_compare coverage: +;;; closure_sort coverage: (let () (define (f3 a b) (let ((x (+ a 1)) (y (+ b 1))) (< x y))) (test (sort! '(1 3 2) f3) '(1 2 3))) -;;; closure_compare_begin +;;; closure_sort_begin (let () (define (f4 a b) (display a #f) (let ((x (+ a 1)) (y (+ b 1))) (< x y))) (test (sort! '(1 3 2) f4) '(1 2 3))) -;;; opt_begin_bool_compare_b +;;; opt_begin_bool_sort_b2 (let () (define (f5 a b) (display a #f) (< a b)) (test (sort! '(1 3 2) f5) '(1 2 3))) -;;; opt_begin_bool_compare_p +;;; opt_begin_bool_sort_b +(let () + (define (f6 a b) (display a #f) (display b #f) (< a b)) + (test (sort! '(1 3 2) f6) '(1 2 3))) +;;; opt_begin_bool_sort_p (let () (define (f6 a b) (display a #f) (if (< a b) #t #f)) (test (sort! '(1 3 2) f6) '(1 2 3))) @@ -37312,6 +37837,10 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (the-environment))))) |# +(let () ; from lisp bboard + (define-macro (circularize . forms) `(begin ,@(let loop ((p forms)) (if (pair? (cdr p)) (loop (cdr p)) (set-cdr! p forms))))) + (test (circularize (+ 1 2) (- 3 4)) 'error)) + (let () ;; how to protect a recursive macro call from being stepped on ;; (define-macro (mac a b) `(if (> ,b 0) (let ((,a (- ,b 1))) (mac ,a (- ,b 1))) ,b)) @@ -37343,7 +37872,6 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta ;; cltl2 p 134ff is an unreadable discussion of this, but I think it says in this case CL goes right to left ;; weird! in CL (decf x (decf x)) != (setf x (- x (setf x (- x 1)))) ;; and (let ((x 10)) (let ((val (decf x))) (decf x val) x))? - ;; so by adhering to one evaluation order, we lose "referential transparency"? [the phrase is opaque, but that's intentional...] (test (let ((x 1+i)) (decf x 0+i)) 1.0)) @@ -85520,8 +86048,8 @@ hi6: (string-app... (test (format #f "~P" 1/0) "s") (test (nan? (string->number "+nan.0")) #t) (test (nan? (string->number "+nan.0" 2)) #t) -(test (equivalent? (string->number "nan.0") (string->number "+nan.0")) #t) -(test (equivalent? (string->number "+inf.0") (string->number "inf.0")) #t) +(test (equivalent? nan.0 (string->number "+nan.0")) #t) +(test (equivalent? (string->number "+inf.0") inf.0) #t) (test (number->string (real-part (log 0.0))) "-inf.0") (test (number->string (real-part (log 0.0)) 2) "-inf.0") @@ -90930,6 +91458,7 @@ etc (test (let () (define (func) (with-let (mock-hash-table) (undefined-function 0))) (define (hi) (func)) (hi)) 'error) (test (let () (define (func) (with-let (mock-hash-table) (let ((x 1)) (undefined-function x)))) (define (hi) (func)) (hi)) 'error) (test (let () (define (func) (with-let (mock-hash-table) (let ((x 1)) (undefined-function (+ x 1))))) (define (hi) (func)) (hi)) 'error) + (test (let () (define (func) (clamp #f (vector (inlet :a 1 :b 2 :c 3) #f #f) (mock-hash-table 'b 2))) (define (hi) (func)) (hi)) 'error) (test (getenv (outlet (mock-string #\h #\o #\h #\o))) 'error) (test (sort! (list 1 2) (mock-vector 1 2 3)) 'error) @@ -91981,6 +92510,15 @@ etc (let ((imp '(0 1))) (define (func) (list (hash-table-ref imp imp) #u(0 1) #r())) (define (hi) (func)) (test (hi) 'error)) (test (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (fill! (curlet) (list-values letrec cond)))) (define (hi) (func)) (hi)) 'error) (let ((x #f)) (define (func) (do ((i 0 (+ i 1))) ((= i 1) x) (set! x (eval-string (object->string (curlet)))))) (define (hi) (func)) (test (hi) (inlet 'i 0))) +(test (let () (define (func) (hash-table-entries (string-ref (iterator-sequence (symbol? x)) #i2d((101 201) (3 4))))) (func)) 'error) +(test (let () (define (_fnc3_ x) (* x 2.0)) (define (f) (_fnc3_ (inlet :a (hash-table 'b 1)))) (f)) 'error) + +(let () + (define (fibf n) (if (< n 2.0) n (+ (fibf (- n 1.0)) (fibf (- n 2.0))))) + (define (clamp minimum x maximum) (min maximum (max x minimum))) + (define (func) (clamp (fibf 8.0) 0 (tree-count 0 (vector-dimensions (block))))) + (define (hi) (func)) + (test (hi) 1)) (test (let ((x #f)) (define (func) (do ((i 0 (+ i 1))) ((= i 1) x) (set! x (let-temporarily ((i 0 (+ i 1))) #i(1) 1)))) (define (hi) (func)) (hi)) 'error) (when with-block @@ -92104,6 +92642,7 @@ etc (test (s7-optimize '((cdadr (cddddr (symbol->string (min '((x 1 . 2) . 3) #<undefined> '((x 1) . 2))))))) #<undefined>) ; #<undefined> is s7-optimize's error value (test (s7-optimize '((set! (cyclic-sequences . 0+0/0i) #f))) #<undefined>) (test (s7-optimize (list (catch #t (lambda () (with-input-from-string "(if (not) (cadddr (rational?)))" read)) (lambda args args)))) #<undefined>) + (test ((s7-optimize '((inlet 'if 3))) 'if) 'error) ) ;;; null sc->args in unbound_variable: @@ -92272,7 +92811,8 @@ etc (test (let () (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (tree-count ((lambda (a) (values a (+ a 1))) 2) (vector-dimensions (block)))))) (define (hi) (func)) (hi)) 'error) - (test (let () (define (func) (append (values "" (block)) (list :go))) (define (hi) (func)) (hi)) 'error)) ; plist clobbered + (test (let () (define (func) (append (values "" (block)) (list :go))) (define (hi) (func)) (hi)) 'error) ; plist clobbered + (test (let ((b (block 1 2 3))) (define (func) (call-with-exit (lambda (x) (x (unspecified? (c-pointer-weak1 b)))))) (func)) 'error)) (test (let () (define (func x i) (float-vector-set! x i (catch #t (lambda () (float-vector-ref x i)) (lambda args 'error)))) (define (hi) (func #r(1 2 3) 3)) (hi)) 'error) (test (let () (define (func) (undefined? (list-ref (list #f (make-iterator (list #f))) 1 ()))) (define (hi) (func)) (hi)) 'error) ; safe_c_opaaaq sc->code != code bug @@ -101049,6 +101589,7 @@ etc (test (let () (define (hi a) (let ((pair? +)) (pair? a 1))) (hi 2)) 3) (test ((lambda (let) (let* ((letrec 1)) (+ letrec let))) 123) 124) +(test (member quasiquote (list 1) (lambda 'ho '(1 2))) 'error) (test (let ((begin 3)) (+ begin 1)) 4) (test ((lambda (let*) (let ((letrec 1)) (+ letrec let*))) 123) 124) @@ -101340,6 +101881,7 @@ etc (test (let ((max min) (min max)) (define (func) (min 10 (max 12 15))) (define (hi) (func)) (hi)) 12) (let ((f #_abs)) (test (set! #_abs +) 'error) (set! abs +) (test (eq? f abs) #f) (test (eq? f #_abs) #t) (set! abs #_abs)) +(test (let ((+ -)) (define (f x) (#_+ x 1)) (object->string f :readable)) "(lambda (x) (#_+ x 1))") (test (catch #t (lambda () ((lambda quote (abs '__a__)))) (lambda (type info) (car info))) "~A: unbound variable") (test (catch #t (lambda () ((lambda quote (+ '__a__ 1)))) (lambda (type info) (car info))) "~A: unbound variable") @@ -101377,6 +101919,46 @@ etc (test (let-temporarily ((else #f)) (mc4 1)) 1)) (test (let () (define (f) (let ((apply cons)) (apply abs -1))) (f)) (cons abs -1)) +(let () ; s7.html examples + (define-macro (my-unless condition . body) + `(with-let (inlet (unlet) :condition ,condition) ; here unlet protects body (format below) + (if (not condition) (begin ,@body)))) + + (let ((not (lambda (x) x)) + (begin 32) + (format abs)) + (test (my-unless #t (format #f "oops")) #<unspecified>) + (test (my-unless #f (format #f "ok")) "ok")) + + (let ((format abs)) + (let ((not (lambda (x) x))) + (test (my-unless #t (format #f "oops")) #<unspecified>) + (test (my-unless #f (format #f "ok")) "ok"))) + + (define my-unless-2 + (let ((op1 (lambda (x) (not x)))) + (define-macro (_ condition . body) + `(with-let (inlet (unlet) (funclet my-unless-2) :condition ,condition) ; funclet to get my-unless-2's version of op1 + (if (op1 condition) (begin ,@body)))))) + + (let ((op1 (lambda (x) x))) + (test (my-unless-2 #t (format #f "oops")) #<unspecified>) + (test (my-unless-2 #f (format #f "ok")) "ok")) + + (define my-unless-3 + (let ((op1 (lambda (x) x))) + (define-macro (_ condition . body) + `(with-let (inlet (unlet) :condition ,condition :local-env (curlet)) ; curlet to get local version of op1 + (if ((with-let local-env op1) condition) (begin ,@body)))))) + + (let ((op1 (lambda (x) (not x)))) + (test (my-unless-3 #t (format #f "oops")) #<unspecified>) + (test (my-unless-3 #f (format #f "ok")) "ok")) + ) + +(test (map when (vector #f #t #f) (list 1 2 3)) '(#<unspecified> 2 #<unspecified>)) +;; (for-each with-let (list (inlet 'x 1) (inlet 'x 2)) (list '(display x) '(display x))): "12" + #| ;;; after much dithering I've decided that built-in C functions have a very aggressive take |