~ chicken-core (chicken-5) 4656323ef76ad9b2c1097c80f5d4226dae1c0ec7
commit 4656323ef76ad9b2c1097c80f5d4226dae1c0ec7
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Mar 14 14:27:36 2011 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Mar 14 14:27:36 2011 +0100
qq simplification
diff --git a/distribution/manifest b/distribution/manifest
index abdc28fe..181792be 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -97,6 +97,7 @@ support.scm
tcp.scm
tests/thread-list.scm
tests/gobble.scm
+tests/trav2.scm
tests/test-optional.scm
tests/arithmetic-test.scm
tests/arithmetic-test.32.expected
diff --git a/expand.scm b/expand.scm
index 8efd4460..27d3f0dd 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1406,17 +1406,17 @@
(else
`(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
(define (simplify x)
- (cond ((match-expression x '(##sys#cons a '()) '(a))
- => (lambda (env) (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)))) )
+ (cond ((match-expression x '(##sys#cons a (##core#quote ())) '(a))
+ => (lambda (env) (simplify `(##sys#list ,(cdr (assq 'a env))))) )
((match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
=> (lambda (env)
- (let ([bxs (assq 'b env)])
+ (let ((bxs (assq 'b env)))
(if (fx< (length bxs) 32)
- (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)
+ (simplify `(##sys#list ,(cdr (assq 'a env))
,@(cdr bxs) ) )
x) ) ) )
- ((match-expression x '(##sys#append a '()) '(a))
- => (lambda (env) (##sys#slot (assq 'a env) 1)) )
+ ((match-expression x '(##sys#append a (##core#quote ())) '(a))
+ => (lambda (env) (cdr (assq 'a env))) )
(else x) ) )
(##sys#check-syntax 'quasiquote form '(_ _))
(walk (cadr form) 0) ) ) ) )
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 4f6677d4..c8827f5e 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -43,6 +43,8 @@ compile="../csc -compiler $CHICKEN -v -I.. -L.. -include-path .. -o a.out"
compile_s="../csc -s -compiler $CHICKEN -v -I.. -L.. -include-path .."
interpret="../csi -n -include-path .."
+rm -f *.exe *.so *.o *.import.* a.out
+
echo "======================================== compiler tests ..."
$compile compiler-tests.scm
./a.out
@@ -125,6 +127,8 @@ $compile syntax-tests.scm
echo "======================================== syntax tests (2, compiled) ..."
$compile syntax-tests-2.scm
./a.out
+$compile trav2.scm
+./a.out
echo "======================================== meta-syntax tests ..."
$interpret -bnq meta-syntax-test.scm -e '(import foo)' -e "(assert (equal? '((1)) (bar 1 2)))" -e "(assert (equal? '(list 1 2 3) (listify)))"
diff --git a/tests/trav2.scm b/tests/trav2.scm
new file mode 100644
index 00000000..f3e309f8
--- /dev/null
+++ b/tests/trav2.scm
@@ -0,0 +1,145 @@
+;;; TRAV2 -- Benchmark which creates and traverses a tree structure.
+
+(define (make-node)
+ (vector 'node '() '() (snb) #f #f #f #f #f #f #f))
+
+(define (node-parents node) (vector-ref node 1))
+(define (node-sons node) (vector-ref node 2))
+(define (node-sn node) (vector-ref node 3))
+(define (node-entry1 node) (vector-ref node 4))
+(define (node-entry2 node) (vector-ref node 5))
+(define (node-entry3 node) (vector-ref node 6))
+(define (node-entry4 node) (vector-ref node 7))
+(define (node-entry5 node) (vector-ref node 8))
+(define (node-entry6 node) (vector-ref node 9))
+(define (node-mark node) (vector-ref node 10))
+
+(define (node-parents-set! node v) (vector-set! node 1 v))
+(define (node-sons-set! node v) (vector-set! node 2 v))
+(define (node-sn-set! node v) (vector-set! node 3 v))
+(define (node-entry1-set! node v) (vector-set! node 4 v))
+(define (node-entry2-set! node v) (vector-set! node 5 v))
+(define (node-entry3-set! node v) (vector-set! node 6 v))
+(define (node-entry4-set! node v) (vector-set! node 7 v))
+(define (node-entry5-set! node v) (vector-set! node 8 v))
+(define (node-entry6-set! node v) (vector-set! node 9 v))
+(define (node-mark-set! node v) (vector-set! node 10 v))
+
+(define *sn* 0)
+(define *rand* 21)
+(define *count* 0)
+(define *marker* #f)
+(define *root* '())
+
+(define (snb)
+ (set! *sn* (+ 1 *sn*))
+ *sn*)
+
+(define (seed)
+ (set! *rand* 21)
+ *rand*)
+
+(define (traverse-random)
+ (set! *rand* (remainder (* *rand* 17) 251))
+ *rand*)
+
+(define (traverse-remove n q)
+ (cond ((eq? (cdr (car q)) (car q))
+ (let ((x (caar q))) (set-car! q '()) x))
+ ((= n 0)
+ (let ((x (caar q)))
+ (do ((p (car q) (cdr p)))
+ ((eq? (cdr p) (car q))
+ (set-cdr! p (cdr (car q)))
+ (set-car! q p)))
+ x))
+ (else (do ((n n (- n 1))
+ (q (car q) (cdr q))
+ (p (cdr (car q)) (cdr p)))
+ ((= n 0) (let ((x (car q))) (set-cdr! q p) x))))))
+
+(define (traverse-select n q)
+ (do ((n n (- n 1))
+ (q (car q) (cdr q)))
+ ((= n 0) (car q))))
+
+(define (add a q)
+ (cond ((null? q)
+ `(,(let ((x `(,a)))
+ (set-cdr! x x) x)))
+ ((null? (car q))
+ (let ((x `(,a)))
+ (set-cdr! x x)
+ (set-car! q x)
+ q))
+ ; the CL version had a useless set-car! in the next line (wc)
+ (else
+ ;; this caused an endless loop in ##sys#append, due to a failing
+ ;; quasiquote-expansion simplification:
+ (set-cdr! (car q) `(,a ,@(cdr (car q))))
+ q)))
+
+(define (create-structure n)
+ (let ((a `(,(make-node))))
+ (do ((m (- n 1) (- m 1))
+ (p a))
+ ((= m 0)
+ (set! a `(,(begin (set-cdr! p a) p)))
+ (do ((unused a)
+ (used (add (traverse-remove 0 a) '()))
+ (x '())
+ (y '()))
+ ((null? (car unused))
+ (find-root (traverse-select 0 used) n))
+ (set! x (traverse-remove (remainder (traverse-random) n) unused))
+ (set! y (traverse-select (remainder (traverse-random) n) used))
+ (add x used)
+ (node-sons-set! y `(,x ,@(node-sons y)))
+ (node-parents-set! x `(,y ,@(node-parents x))) ))
+ (set! a (cons (make-node) a)))))
+
+(define (find-root node n)
+ (do ((n n (- n 1)))
+ ((or (= n 0) (null? (node-parents node)))
+ node)
+ (set! node (car (node-parents node)))))
+
+(define (travers node mark)
+ (cond ((eq? (node-mark node) mark) #f)
+ (else (node-mark-set! node mark)
+ (set! *count* (+ 1 *count*))
+ (node-entry1-set! node (not (node-entry1 node)))
+ (node-entry2-set! node (not (node-entry2 node)))
+ (node-entry3-set! node (not (node-entry3 node)))
+ (node-entry4-set! node (not (node-entry4 node)))
+ (node-entry5-set! node (not (node-entry5 node)))
+ (node-entry6-set! node (not (node-entry6 node)))
+ (do ((sons (node-sons node) (cdr sons)))
+ ((null? sons) #f)
+ (travers (car sons) mark)))))
+
+(define (traverse root)
+ (let ((*count* 0))
+ (travers root (begin (set! *marker* (not *marker*)) *marker*))
+ *count*))
+
+(define (init-traverse) ; Changed from defmacro to defun \bs
+ (set! *root* (create-structure 100))
+ #f)
+
+(define (run-traverse) ; Changed from defmacro to defun \bs
+ (do ((i 50 (- i 1)))
+ ((= i 0))
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)))
+
+;;; to initialize, call: (init-traverse)
+;;; to run traverse, call: (run-traverse)
+
+(print "init ...")
+(init-traverse)
+(print "run ...")
+(run-traverse)
Trap