~ chicken-core (chicken-5) c54824f75f025038c8f367fc9568da450d4ea68a
commit c54824f75f025038c8f367fc9568da450d4ea68a
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Jan 31 00:44:09 2015 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sat Jan 31 00:44:09 2015 +0100
More fixing for mini-srfi-1
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 31608bcd..b58ae106 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -784,7 +784,7 @@
(##core#let
((,lvar (,%length ,rvar)))
,(foldr
- (lambda (body c)
+ (lambda (c body)
(##sys#decompose-lambda-list
(car c)
(lambda (vars argc rest)
diff --git a/core.scm b/core.scm
index 4cd4d9e0..afe0f49e 100644
--- a/core.scm
+++ b/core.scm
@@ -2384,7 +2384,7 @@
(lambda (vars argc rest)
(let ((id (if here (first params) 'toplevel)))
(fluid-let ((lexicals (append locals lexicals)))
- (let ((c (delete-duplicates (gather (first subs) id vars))))
+ (let ((c (delete-duplicates (gather (first subs) id vars) eq?)))
(db-put! db id 'closure-size (length c))
(db-put! db id 'captured-variables c)
(lset-difference c locals vars)))))))
diff --git a/mini-srfi-1.scm b/mini-srfi-1.scm
index 1b20c441..155ce79a 100644
--- a/mini-srfi-1.scm
+++ b/mini-srfi-1.scm
@@ -48,7 +48,7 @@
(define (take lst n)
(if (fx<= n 0)
'()
- (cons (car lst) (take lst (fx- n 1)))))
+ (cons (car lst) (take (cdr lst) (fx- n 1)))))
(define (drop lst n)
(let loop ((lst lst) (n n))
diff --git a/optimizer.scm b/optimizer.scm
index d0d1d55d..7df97da7 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -214,7 +214,7 @@
(cond ((not ok)
(unless odirty (set! dirty #f))
(set! broken-constant-nodes
- (lset-adjoin eq? broken-constant-nodes n1))
+ (lset-adjoin broken-constant-nodes n1))
n1)
(else
(touch)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index bd043808..d4c808b4 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1252,7 +1252,7 @@
(if (any (cut eq? 'procedure <>) ts)
'procedure
(foldl
- (lambda (t pt)
+ (lambda (pt t)
(let* ((name1 (procedure-name t))
(atypes1 (procedure-arguments t))
(rtypes1 (procedure-results t))
@@ -2076,7 +2076,7 @@
,(map (lambda (tv)
(cond ((assq tv constraints) => identity)
(else tv)))
- (delete-duplicates typevars))
+ (delete-duplicates typevars eq?))
,type)))
(let ((type2 (simplify-type type)))
(values
@@ -2335,7 +2335,7 @@
;; collect candidates for each typevar
(define (collect)
- (let* ((vars (delete-duplicates (concatenate (map unzip1 insts))))
+ (let* ((vars (delete-duplicates (concatenate (map unzip1 insts)) eq?))
(all (map (lambda (var)
(cons
var
@@ -2352,7 +2352,7 @@
(ddd " over-all-instantiations: ~s exact=~a" tlist exact)
;; process all tlist elements
- (let loop ((ts (delete-duplicates tlist))
+ (let loop ((ts (delete-duplicates tlist eq?))
(ok #f))
(cond ((null? ts)
(cond ((or ok (null? tlist))
diff --git a/support.scm b/support.scm
index bffedf43..db1e5fc3 100644
--- a/support.scm
+++ b/support.scm
@@ -646,10 +646,10 @@
llist
(lambda (vars argc rest)
(receive (largs rargs) (split-at args argc)
- (let* ([rlist (if copy? (map gensym vars) vars)]
- [body (if copy?
+ (let* ((rlist (if copy? (map gensym vars) vars))
+ (body (if copy?
(copy-node-tree-and-rename body vars rlist db cfk)
- body) ] )
+ body) ) )
(let loop ((vars (take rlist argc))
(vals largs))
(if (null? vars)
diff --git a/tests/apply-test.scm b/tests/apply-test.scm
index 568b9678..b5c1da32 100644
--- a/tests/apply-test.scm
+++ b/tests/apply-test.scm
@@ -6,7 +6,17 @@
'()
(cons (proc i) (loop (fx+ i 1))))))
-(define (iota n) (list-tabulate n (lambda (i) i)))
+(define-for-syntax (list-tabulate n proc)
+ (let loop ((i 0))
+ (if (fx>= i n)
+ '()
+ (cons (proc i) (loop (fx+ i 1))))))
+
+(define (last lst)
+ (let loop ((lst lst))
+ (if (null? (cdr lst))
+ (car lst)
+ (loop (cdr lst)))))
(define max-argcount ##sys#apply-argument-limit)
@@ -30,7 +40,7 @@
(printf "testing 'apply' with 0..~A (maximum apply argument count)...\n" max-argcount)
(do ((i 0 (add1 i)))
((>= i max-argcount))
- (apply foo (iota i 1)))
+ (apply foo (list-tabulate i add1)))
(let-syntax
((invoke-directly
@@ -39,13 +49,13 @@
`(begin
(print "invoking directly with 0..50...")
;; Lowest edge cases
- ,@(list-tabulate 50 (lambda (i) `(foo ,@(iota i 1))))
+ ,@(list-tabulate 50 (lambda (i) `(foo ,@(list-tabulate i add1))))
(printf "invoking directly with ~A..~A (maximum ~A direct argument count)...\n"
,(- max-direct-argcount 50) ,max-direct-argcount
(cond-expand (compiling "compiled") (else "interpreted")))
;; Highest edge cases
,@(list-tabulate
- 50 (lambda (i) `(foo ,@(iota (- max-direct-argcount i) 1)))))))))
+ 50 (lambda (i) `(foo ,@(list-tabulate (- max-direct-argcount i) add1)))))))))
(print "If this segfaults on x86-64, try updating GCC (4.5 has a code-generation bug):")
(invoke-directly))
@@ -56,11 +66,11 @@
((exn runtime limit) 'a-okay))))))
(print "testing 'apply' can detect calls of too many arguments...")
-(assert-argcount-error (apply foo (iota (add1 max-argcount) 1)))
+(assert-argcount-error (apply foo (list-tabulate (add1 max-argcount) add1)))
(print "testing direct invocation can detect calls of too many arguments...")
(let-syntax ((invoke-directly-with-too-many-args
(ir-macro-transformer
(lambda (i r c)
- `(assert-argcount-error (foo ,@(iota (add1 max-direct-argcount) 1)))))))
+ `(assert-argcount-error (foo ,@(list-tabulate (add1 max-direct-argcount) add1)))))))
(invoke-directly-with-too-many-args))
diff --git a/tests/environment-tests.scm b/tests/environment-tests.scm
index 86cb598b..b6680d41 100644
--- a/tests/environment-tests.scm
+++ b/tests/environment-tests.scm
@@ -40,11 +40,11 @@
(define (bar) 99))
(define foo-env (module-environment 'foo))
-(define srfi-4-env (module-environment 'srfi-4))
+(define ds-env (module-environment 'data-structures))
(test-equal (eval '(bar) foo-env) 99)
(test-error (eval 'baz foo-env))
-(test-equal (eval '(u8vector 1 2) srfi-4-env) '#u8(1 2))
-(test-error (eval 'baz srf-4-env))
+(test-equal (eval '(conc 1 2) ds-env) "12")
+(test-error (eval 'baz ds-env))
(test-end)
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
index b7975849..1c71ddf2 100644
--- a/tests/functor-tests.scm
+++ b/tests/functor-tests.scm
@@ -13,6 +13,11 @@
(include "test-queue")
(include "breadth-first")
+(define (take lst n)
+ (if (fx<= n 0)
+ '()
+ (cons (car lst) (take (cdr lst) (fx- n 1)))))
+
(module queue1 QUEUE
(import (rename scheme
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 0a20acd4..bdf74fbf 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -7,6 +7,18 @@
((_ exp)
(assert (handle-exceptions ex #t exp #f)))))
+(define (list-tabulate n proc)
+ (let loop ((i 0))
+ (if (fx>= i n)
+ '()
+ (cons (proc i) (loop (fx+ i 1))))))
+
+(define (every pred lst)
+ (let loop ((lst lst))
+ (cond ((null? lst))
+ ((not (pred (car lst))) #f)
+ (else (loop (cdr lst))))))
+
;; numbers
(assert (not (not 3)))
@@ -226,7 +238,7 @@
;; by Christian Kellermann
(assert
(equal?
- (map (lambda (n) (number->string 32 n)) (iota 15 2))
+ (map (lambda (n) (number->string 32 n)) (list-tabulate 15 (cut + 2 <>)))
'("100000" "1012" "200" "112" "52" "44" "40" "35" "32" "2A" "28" "26" "24" "22" "20")))
diff --git a/tests/reexport-m2.scm b/tests/reexport-m2.scm
index daee95f8..923491a9 100644
--- a/tests/reexport-m2.scm
+++ b/tests/reexport-m2.scm
@@ -3,4 +3,4 @@
(module foo ()
(import scheme chicken)
(use reexport-m1)
- (print (cons* 1 2 3)))
+ (print (cons 1 2)))
diff --git a/tests/srfi-4-tests.scm b/tests/srfi-4-tests.scm
index 59e265d7..addbf56d 100644
--- a/tests/srfi-4-tests.scm
+++ b/tests/srfi-4-tests.scm
@@ -20,9 +20,9 @@
(assert (= 99 (,(conc "vector-ref") x 1)))
(assert (= 2 (,(conc "vector-length") x)))
(assert
- (every =
- '(100 99)
- (,(conc "vector->list") x))))))))
+ (let ((result (,(conc "vector->list") x)))
+ (and (= 100 (car result))
+ (= 99 (cadr result))))))))))
(test1 u8)
(test1 u16)
diff --git a/tests/test-finalizers-2.scm b/tests/test-finalizers-2.scm
index 156d3a5a..09efe02d 100644
--- a/tests/test-finalizers-2.scm
+++ b/tests/test-finalizers-2.scm
@@ -7,6 +7,14 @@
'()
(cons (proc i) (loop (fx+ i 1))))))
+(define (circular-list x1 . lst)
+ (let ((lst1 (cons x1 lst)))
+ (let loop ((lst lst1))
+ (if (null? (cdr lst))
+ (set-cdr! lst lst1)
+ (loop (cdr lst))))
+ lst1))
+
(define *n* 1000)
(define *count* 0)
diff --git a/tests/test-queue.scm b/tests/test-queue.scm
index 00e53242..278a3e2d 100644
--- a/tests/test-queue.scm
+++ b/tests/test-queue.scm
@@ -6,10 +6,9 @@
(functor (test-queue (Q QUEUE)) *
(import scheme chicken Q)
- (use srfi-1)
(define (list->queue lst)
- (fold (lambda (x q) (enqueue q x)) empty-queue lst))
+ (foldl (lambda (q x) (enqueue q x)) empty-queue lst))
(define (queue->list q)
(if (empty? q)
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 71fe84fa..1e254cd1 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -274,9 +274,6 @@
(mx fixnum (##sys#vector-ref '#(1 2 3.4) 0))
(mx (vector fixnum float) (vector 1 2.3))
(mx (list fixnum float) (list 1 2.3))
-(mx (list fixnum float) (list-copy (list 1 2.3)))
-(mx (pair fixnum float) (list-copy (cons 1 2.3)))
-(mx fixnum (list-copy 1))
(mx fixnum (list-ref (list 1 2.3) 0))
(mx fixnum (list-ref (cons 1 2.3) 0))
(mx float (list-ref (list 1 2.3) 1))
@@ -285,18 +282,6 @@
(mx (list float) (list-tail (list 1 2.3) 1))
(mx float (list-tail (cons 1 2.3) 1))
(mx null (list-tail (list 1 2.3) 2))
-(mx (list fixnum float) (drop (list 1 2.3) 0))
-(mx (pair fixnum float) (drop (cons 1 2.3) 0))
-(mx (list float) (drop (list 1 2.3) 1))
-(mx float (drop (cons 1 2.3) 1))
-(mx null (drop (list 1 2.3) 2))
-(mx null (take (list 1 2.3) 0))
-(mx null (take (cons 1 2.3) 0))
-(mx (list fixnum) (take (list 1 2.3) 1))
-(mx (list fixnum) (take (cons 1 2.3) 1))
-(mx (list fixnum float) (take (list 1 2.3) 2))
-(mx (list * *) (make-list 2))
-(mx (list string string) (make-list 2 "a"))
(mx (vector * *) (make-vector 2))
(mx (vector string string) (make-vector 2 "a"))
(mx null (reverse '()))
Trap