* Re: Segfault when running fibc benchmark in current trunk
2009-04-17 7:30 ` Andy Wingo
2009-04-19 16:28 ` Juhani Rantanen
@ 2009-04-19 22:02 ` Juhani Rantanen
[not found] ` <39231.87.93.21.245.1240178567.squirrel@webmail.aj-group.net>
2 siblings, 0 replies; 8+ messages in thread
From: Juhani Rantanen @ 2009-04-19 22:02 UTC (permalink / raw)
To: Andy Wingo; +Cc: bug-guile, Juhani Rantanen
[-- Attachment #1: Type: text/plain, Size: 1038 bytes --]
> I look forward to the next bug report :)
Here are some more files that don't need the benchmark suite to run. I
also ran all of the tests with Gambit and there wasn't any errors.
Testing maze under Guile-r5rs
Compiling...
Running...
ERROR: In procedure zero?:
ERROR: Wrong type argument in position 1: #f
Testing trav2 under Guile-r5rs
Compiling...
Running...
ERROR: In procedure memoization:
ERROR: Non-list result for unquote-splicing (#(node () () 1 #f #f #f #f #f
#f ...) . #0#) in expression ((unquote-splicing (#<variable b7f5ff18
value: #<primitive-procedure cdr>> (#<variable b7f5ff48 value:
#<primitive-procedure car>> #@0+1)))).
Testing trav1 under Guile-r5rs
Compiling...
Running...
ERROR: In procedure memoization:
ERROR: Non-list result for unquote-splicing (#(node () () 1 #f #f #f #f #f
#f ...) . #0#) in expression ((unquote-splicing (#<variable b7f44f18
value: #<primitive-procedure cdr>> (#<variable b7f44f48 value:
#<primitive-procedure car>> #@0+1)))).
Best Regards,
Juhani
[-- Attachment #2: maze_bug.scm --]
[-- Type: application/octet-stream, Size: 25246 bytes --]
(define (run-bench name count ok? run)
(let loop ((i count) (result '(undefined)))
(if (< 0 i)
(loop (- i 1) (run))
result)))
(define (run-benchmark name count ok? run-maker . args)
(newline)
(let* ((run (apply run-maker args))
(result (run-bench name count ok? run)))
(if (not (ok? result))
(begin
(display "*** wrong result ***")
(newline)
(display "*** got: ")
(write result)
(newline)))))
(define (fatal-error . args)
(for-each display args)
(newline)
(exit 1))
(define (call-with-output-file/truncate filename proc)
(call-with-output-file filename proc))
(define maze-iters 400)
;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers.
;------------------------------------------------------------------------------
; Was file "rand.scm".
; Minimal Standard Random Number Generator
; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
; better constants, as proposed by Park.
; By Ozan Yigit
;;; Rehacked by Olin 4/1995.
(define (random-state n)
(cons n #f))
(define (rand state)
(let ((seed (car state))
(A 2813) ; 48271
(M 8388607) ; 2147483647
(Q 2787) ; 44488
(R 2699)) ; 3399
(let* ((hi (quotient seed Q))
(lo (modulo seed Q))
(test (- (* A lo) (* R hi)))
(val (if (> test 0) test (+ test M))))
(set-car! state val)
val)))
(define (random-int n state)
(modulo (rand state) n))
;------------------------------------------------------------------------------
; Was file "uf.scm".
;;; Tarjan's amortised union-find data structure.
;;; Copyright (c) 1995 by Olin Shivers.
;;; This data structure implements disjoint sets of elements.
;;; Four operations are supported. The implementation is extremely
;;; fast -- any sequence of N operations can be performed in time
;;; so close to linear it's laughable how close it is. See your
;;; intro data structures book for more. The operations are:
;;;
;;; - (base-set nelts) -> set
;;; Returns a new set, of size NELTS.
;;;
;;; - (set-size s) -> integer
;;; Returns the number of elements in set S.
;;;
;;; - (union! set1 set2)
;;; Unions the two sets -- SET1 and SET2 are now considered the same set
;;; by SET-EQUAL?.
;;;
;;; - (set-equal? set1 set2)
;;; Returns true <==> the two sets are the same.
;;; Representation: a set is a cons cell. Every set has a "representative"
;;; cons cell, reached by chasing cdr links until we find the cons with
;;; cdr = (). Set equality is determined by comparing representatives using
;;; EQ?. A representative's car contains the number of elements in the set.
;;; The speed of the algorithm comes because when we chase links to find
;;; representatives, we collapse links by changing all the cells in the path
;;; we followed to point directly to the representative, so that next time
;;; we walk the cdr-chain, we'll go directly to the representative in one hop.
(define (base-set nelts) (cons nelts '()))
;;; Sets are chained together through cdr links. Last guy in the chain
;;; is the root of the set.
(define (get-set-root s)
(let lp ((r s)) ; Find the last pair
(let ((next (cdr r))) ; in the list. That's
(cond ((pair? next) (lp next)) ; the root r.
(else
(if (not (eq? r s)) ; Now zip down the list again,
(let lp ((x s)) ; changing everyone's cdr to r.
(let ((next (cdr x)))
(cond ((not (eq? r next))
(set-cdr! x r)
(lp next))))))
r))))) ; Then return r.
(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2)))
(define (set-size s) (car (get-set-root s)))
(define (union! s1 s2)
(let* ((r1 (get-set-root s1))
(r2 (get-set-root s2))
(n1 (set-size r1))
(n2 (set-size r2))
(n (+ n1 n2)))
(cond ((> n1 n2)
(set-cdr! r2 r1)
(set-car! r1 n))
(else
(set-cdr! r1 r2)
(set-car! r2 n)))))
;------------------------------------------------------------------------------
; Was file "maze.scm".
;;; Building mazes with union/find disjoint sets.
;;; Copyright (c) 1995 by Olin Shivers.
;;; This is the algorithmic core of the maze constructor.
;;; External dependencies:
;;; - RANDOM-INT
;;; - Union/find code
;;; - bitwise logical functions
; (define-record wall
; owner ; Cell that owns this wall.
; neighbor ; The other cell bordering this wall.
; bit) ; Integer -- a bit identifying this wall in OWNER's cell.
; (define-record cell
; reachable ; Union/find set -- all reachable cells.
; id ; Identifying info (e.g., the coords of the cell).
; (walls -1) ; A bitset telling which walls are still standing.
; (parent #f) ; For DFS spanning tree construction.
; (mark #f)) ; For marking the solution path.
(define (make-wall owner neighbor bit)
(vector 'wall owner neighbor bit))
(define (wall:owner o) (vector-ref o 1))
(define (set-wall:owner o v) (vector-set! o 1 v))
(define (wall:neighbor o) (vector-ref o 2))
(define (set-wall:neighbor o v) (vector-set! o 2 v))
(define (wall:bit o) (vector-ref o 3))
(define (set-wall:bit o v) (vector-set! o 3 v))
(define (make-cell reachable id)
(vector 'cell reachable id -1 #f #f))
(define (cell:reachable o) (vector-ref o 1))
(define (set-cell:reachable o v) (vector-set! o 1 v))
(define (cell:id o) (vector-ref o 2))
(define (set-cell:id o v) (vector-set! o 2 v))
(define (cell:walls o) (vector-ref o 3))
(define (set-cell:walls o v) (vector-set! o 3 v))
(define (cell:parent o) (vector-ref o 4))
(define (set-cell:parent o v) (vector-set! o 4 v))
(define (cell:mark o) (vector-ref o 5))
(define (set-cell:mark o v) (vector-set! o 5 v))
;;; Iterates in reverse order.
(define (vector-for-each proc v)
(let lp ((i (- (vector-length v) 1)))
(cond ((>= i 0)
(proc (vector-ref v i))
(lp (- i 1))))))
;;; Randomly permute a vector.
(define (permute-vec! v random-state)
(let lp ((i (- (vector-length v) 1)))
(cond ((> i 1)
(let ((elt-i (vector-ref v i))
(j (random-int i random-state))) ; j in [0,i)
(vector-set! v i (vector-ref v j))
(vector-set! v j elt-i))
(lp (- i 1)))))
v)
;;; This is the core of the algorithm.
(define (dig-maze walls ncells)
(call-with-current-continuation
(lambda (quit)
(vector-for-each
(lambda (wall) ; For each wall,
(let* ((c1 (wall:owner wall)) ; find the cells on
(set1 (cell:reachable c1))
(c2 (wall:neighbor wall)) ; each side of the wall
(set2 (cell:reachable c2)))
;; If there is no path from c1 to c2, knock down the
;; wall and union the two sets of reachable cells.
;; If the new set of reachable cells is the whole set
;; of cells, quit.
(if (not (set-equal? set1 set2))
(let ((walls (cell:walls c1))
(wall-mask (bitwise-not (wall:bit wall))))
(union! set1 set2)
(set-cell:walls c1 (bitwise-and walls wall-mask))
(if (= (set-size set1) ncells) (quit #f))))))
walls))))
;;; Some simple DFS routines useful for determining path length
;;; through the maze.
;;; Build a DFS tree from ROOT.
;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children.
;;; We assume there are no loops in the maze; if this is incorrect, the
;;; algorithm will diverge.
(define (dfs-maze maze root do-children)
(let search ((node root) (parent #f))
(set-cell:parent node parent)
(do-children (lambda (child)
(if (not (eq? child parent))
(search child node)))
maze node)))
;;; Move the root to NEW-ROOT.
(define (reroot-maze new-root)
(let lp ((node new-root) (new-parent #f))
(let ((old-parent (cell:parent node)))
(set-cell:parent node new-parent)
(if old-parent (lp old-parent node)))))
;;; How far from CELL to the root?
(define (path-length cell)
(do ((len 0 (+ len 1))
(node (cell:parent cell) (cell:parent node)))
((not node) len)))
;;; Mark the nodes from NODE back to root. Used to mark the winning path.
(define (mark-path node)
(let lp ((node node))
(set-cell:mark node #t)
(cond ((cell:parent node) => lp))))
;------------------------------------------------------------------------------
; Was file "harr.scm".
;;; Hex arrays
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - define-record
;;; ___ ___ ___
;;; / \ / \ / \
;;; ___/ A \___/ A \___/ A \___
;;; / \ / \ / \ / \
;;; / A \___/ A \___/ A \___/ A \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; / \ / \ / \ / \
;;; / \___/ \___/ \___/ \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; / \ / \ / \ / \
;;; / \___/ \___/ \___/ \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal
;;; element. Hexes are three wide and two high; e.g., to get from the center
;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)}
;;; respectively.
;;;
;;; Hex arrays are represented with a matrix, essentially made by shoving the
;;; odd columns down a half-cell so things line up. The mapping is as follows:
;;; Center coord row/column
;;; ------------ ----------
;;; (x, y) -> (y/2, x/3)
;;; (3c, 2r + c&1) <- (r, c)
; (define-record harr
; nrows
; ncols
; elts)
(define (make-harr nrows ncols elts)
(vector 'harr nrows ncols elts))
(define (harr:nrows o) (vector-ref o 1))
(define (set-harr:nrows o v) (vector-set! o 1 v))
(define (harr:ncols o) (vector-ref o 2))
(define (set-harr:ncols o v) (vector-set! o 2 v))
(define (harr:elts o) (vector-ref o 3))
(define (set-harr:elts o v) (vector-set! o 3 v))
(define (harr r c)
(make-harr r c (make-vector (* r c))))
(define (href ha x y)
(let ((r (quotient y 2))
(c (quotient x 3)))
(vector-ref (harr:elts ha)
(+ (* (harr:ncols ha) r) c))))
(define (hset! ha x y val)
(let ((r (quotient y 2))
(c (quotient x 3)))
(vector-set! (harr:elts ha)
(+ (* (harr:ncols ha) r) c)
val)))
(define (href/rc ha r c)
(vector-ref (harr:elts ha)
(+ (* (harr:ncols ha) r) c)))
;;; Create a nrows x ncols hex array. The elt centered on coord (x, y)
;;; is the value returned by (PROC x y).
(define (harr-tabulate nrows ncols proc)
(let ((v (make-vector (* nrows ncols))))
(do ((r (- nrows 1) (- r 1)))
((< r 0))
(do ((c 0 (+ c 1))
(i (* r ncols) (+ i 1)))
((= c ncols))
(vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1))))))
(make-harr nrows ncols v)))
(define (harr-for-each proc harr)
(vector-for-each proc (harr:elts harr)))
;------------------------------------------------------------------------------
; Was file "hex.scm".
;;; Hexagonal hackery for maze generation.
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - cell and wall records
;;; - Functional Postscript for HEXES->PATH
;;; - logical functions for bit hacking
;;; - hex array code.
;;; To have the maze span (0,0) to (1,1):
;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows)))
;;; (translate (point 2 1) maze))
;;; Every elt of the hex array manages his SW, S, and SE wall.
;;; Terminology: - An even column is one whose column index is even. That
;;; means the first, third, ... columns (indices 0, 2, ...).
;;; - An odd column is one whose column index is odd. That
;;; means the second, fourth... columns (indices 1, 3, ...).
;;; The even/odd flip-flop is confusing; be careful to keep it
;;; straight. The *even* columns are the low ones. The *odd*
;;; columns are the high ones.
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/
;;; 0 1 2 3
(define south-west 1)
(define south 2)
(define south-east 4)
(define (gen-maze-array r c)
(harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y)))))
;;; This could be made more efficient.
(define (make-wall-vec harr)
(let* ((nrows (harr:nrows harr))
(ncols (harr:ncols harr))
(xmax (* 3 (- ncols 1)))
;; Accumulate walls.
(walls '())
(add-wall (lambda (o n b) ; owner neighbor bit
(set! walls (cons (make-wall o n b) walls)))))
;; Do everything but the bottom row.
(do ((x (* (- ncols 1) 3) (- x 3)))
((< x 0))
(do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1))
(- y 2)))
((<= y 1)) ; Don't do bottom row.
(let ((hex (href harr x y)))
(if (not (zero? x))
(add-wall hex (href harr (- x 3) (- y 1)) south-west))
(add-wall hex (href harr x (- y 2)) south)
(if (< x xmax)
(add-wall hex (href harr (+ x 3) (- y 1)) south-east)))))
;; Do the SE and SW walls of the odd columns on the bottom row.
;; If the rightmost bottom hex lies in an odd column, however,
;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor.
(if (> ncols 1)
(let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2)))))
;; Do rightmost odd col.
(let ((rmoc-hex (href harr rmoc-x 1)))
(if (< rmoc-x xmax) ; Not a corner -- do E wall.
(add-wall rmoc-hex (href harr xmax 0) south-east))
(add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west))
(do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols.
(- x 6)))
((< x 3)) ; 3 is X coord of leftmost odd column.
(add-wall (href harr x 1) (href harr (- x 3) 0) south-west)
(add-wall (href harr x 1) (href harr (+ x 3) 0) south-east))))
(list->vector walls)))
;;; Find the cell ctop from the top row, and the cell cbot from the bottom
;;; row such that cbot is furthest from ctop.
;;; Return [ctop-x, ctop-y, cbot-x, cbot-y].
(define (pick-entrances harr)
(dfs-maze harr (href/rc harr 0 0) for-each-hex-child)
(let ((nrows (harr:nrows harr))
(ncols (harr:ncols harr)))
(let tp-lp ((max-len -1)
(entrance #f)
(exit #f)
(tcol (- ncols 1)))
(if (< tcol 0) (vector entrance exit)
(let ((top-cell (href/rc harr (- nrows 1) tcol)))
(reroot-maze top-cell)
(let ((result
(let bt-lp ((max-len max-len)
(entrance entrance)
(exit exit)
(bcol (- ncols 1)))
; (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol)
(if (< bcol 0) (vector max-len entrance exit)
(let ((this-len (path-length (href/rc harr 0 bcol))))
(if (> this-len max-len)
(bt-lp this-len tcol bcol (- bcol 1))
(bt-lp max-len entrance exit (- bcol 1))))))))
(let ((max-len (vector-ref result 0))
(entrance (vector-ref result 1))
(exit (vector-ref result 2)))
(tp-lp max-len entrance exit (- tcol 1)))))))))
;;; Apply PROC to each node reachable from CELL.
(define (for-each-hex-child proc harr cell)
(let* ((walls (cell:walls cell))
(id (cell:id cell))
(x (car id))
(y (cdr id))
(nr (harr:nrows harr))
(nc (harr:ncols harr))
(maxy (* 2 (- nr 1)))
(maxx (* 3 (- nc 1))))
(if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1))))
(if (not (bit-test walls south)) (proc (href harr x (- y 2))))
(if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1))))
;; NW neighbor, if there is one (we may be in col 1, or top row/odd col)
(if (and (> x 0) ; Not in first column.
(or (<= y maxy) ; Not on top row or
(zero? (modulo x 6)))) ; not in an odd column.
(let ((nw (href harr (- x 3) (+ y 1))))
(if (not (bit-test (cell:walls nw) south-east)) (proc nw))))
;; N neighbor, if there is one (we may be on top row).
(if (< y maxy) ; Not on top row
(let ((n (href harr x (+ y 2))))
(if (not (bit-test (cell:walls n) south)) (proc n))))
;; NE neighbor, if there is one (we may be in last col, or top row/odd col)
(if (and (< x maxx) ; Not in last column.
(or (<= y maxy) ; Not on top row or
(zero? (modulo x 6)))) ; not in an odd column.
(let ((ne (href harr (+ x 3) (+ y 1))))
(if (not (bit-test (cell:walls ne) south-west)) (proc ne))))))
;;; The top-level
(define (make-maze nrows ncols)
(let* ((cells (gen-maze-array nrows ncols))
(walls (permute-vec! (make-wall-vec cells) (random-state 20))))
(dig-maze walls (* nrows ncols))
(let ((result (pick-entrances cells)))
(let ((entrance (vector-ref result 0))
(exit (vector-ref result 1)))
(let* ((exit-cell (href/rc cells 0 exit))
(walls (cell:walls exit-cell)))
(reroot-maze (href/rc cells (- nrows 1) entrance))
(mark-path exit-cell)
(set-cell:walls exit-cell (bitwise-and walls (bitwise-not south)))
(vector cells entrance exit))))))
(define (pmaze nrows ncols)
(let ((result (make-maze nrows ncols)))
(let ((cells (vector-ref result 0))
(entrance (vector-ref result 1))
(exit (vector-ref result 2)))
(print-hexmaze cells entrance))))
;------------------------------------------------------------------------------
; Was file "hexprint.scm".
;;; Print out a hex array with characters.
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - hex array code
;;; - hex cell code
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/
;;; Top part of top row looks like this:
;;; _ _ _ _
;;; _/ \_/ \/ \_/ \
;;; /
(define output #f) ; the list of all characters written out, in reverse order.
(define (write-ch c)
(set! output (cons c output)))
(define (print-hexmaze harr entrance)
(let* ((nrows (harr:nrows harr))
(ncols (harr:ncols harr))
(ncols2 (* 2 (quotient ncols 2))))
;; Print out the flat tops for the top row's odd cols.
(do ((c 1 (+ c 2)))
((>= c ncols))
; (display " ")
(write-ch #\space)
(write-ch #\space)
(write-ch #\space)
(write-ch (if (= c entrance) #\space #\_)))
; (newline)
(write-ch #\newline)
;; Print out the slanted tops for the top row's odd cols
;; and the flat tops for the top row's even cols.
(write-ch #\space)
(do ((c 0 (+ c 2)))
((>= c ncols2))
; (format #t "~a/~a\\"
; (if (= c entrance) #\space #\_)
; (dot/space harr (- nrows 1) (+ c 1)))
(write-ch (if (= c entrance) #\space #\_))
(write-ch #\/)
(write-ch (dot/space harr (- nrows 1) (+ c 1)))
(write-ch #\\))
(if (odd? ncols)
(write-ch (if (= entrance (- ncols 1)) #\space #\_)))
; (newline)
(write-ch #\newline)
(do ((r (- nrows 1) (- r 1)))
((< r 0))
;; Do the bottoms for row r's odd cols.
(write-ch #\/)
(do ((c 1 (+ c 2)))
((>= c ncols2))
;; The dot/space for the even col just behind c.
(write-ch (dot/space harr r (- c 1)))
(display-hexbottom (cell:walls (href/rc harr r c))))
(cond ((odd? ncols)
(write-ch (dot/space harr r (- ncols 1)))
(write-ch #\\)))
; (newline)
(write-ch #\newline)
;; Do the bottoms for row r's even cols.
(do ((c 0 (+ c 2)))
((>= c ncols2))
(display-hexbottom (cell:walls (href/rc harr r c)))
;; The dot/space is for the odd col just after c, on row below.
(write-ch (dot/space harr (- r 1) (+ c 1))))
(cond ((odd? ncols)
(display-hexbottom (cell:walls (href/rc harr r (- ncols 1)))))
((not (zero? r)) (write-ch #\\)))
; (newline)
(write-ch #\newline))))
(define (bit-test j bit)
(not (zero? (bitwise-and j bit))))
;;; Return a . if harr[r,c] is marked, otherwise a space.
;;; We use the dot to mark the solution path.
(define (dot/space harr r c)
(if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space))
;;; Print a \_/ hex bottom.
(define (display-hexbottom hexwalls)
(write-ch (if (bit-test hexwalls south-west) #\\ #\space))
(write-ch (if (bit-test hexwalls south ) #\_ #\space))
(write-ch (if (bit-test hexwalls south-east) #\/ #\space)))
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/
;------------------------------------------------------------------------------
(define (run nrows ncols)
(set! output '())
(pmaze nrows ncols)
(reverse output))
(define (main . args)
(run-benchmark
"maze"
maze-iters
(lambda (result)
(equal? result '
(#\ #\ #\ #\_ #\ #\ #\ #\_ #\ #\ #\ #\_ #\newline
#\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\newline
#\/ #\ #\\ #\ #\ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\newline
#\\ #\ #\ #\ #\\ #\ #\/ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
#\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\/ #\newline
#\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline
#\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\newline
#\/ #\ #\\ #\ #\/ #\. #\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\newline
#\\ #\_ #\/ #\ #\\ #\ #\/ #\. #\ #\_ #\ #\. #\\ #\ #\/ #\newline
#\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\ #\\ #\ #\ #\ #\\ #\newline
#\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline
#\\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\_ #\/ #\newline
#\/ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\. #\\ #\newline
#\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\\ #\_ #\ #\ #\\ #\ #\/ #\. #\\ #\ #\ #\. #\\ #\newline
#\\ #\ #\/ #\. #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\ #\ #\ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\newline
#\\ #\ #\/ #\. #\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\ #\/ #\newline
#\/ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\newline
#\\ #\_ #\ #\ #\\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline
#\/ #\ #\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\ #\\ #\newline
#\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline
#\/ #\ #\\ #\ #\/ #\ #\ #\_ #\ #\. #\ #\_ #\ #\ #\\ #\newline
#\\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\ #\ #\\ #\_ #\/ #\newline
#\/ #\ #\ #\_ #\ #\ #\\ #\ #\ #\ #\\ #\_ #\/ #\ #\\ #\newline
#\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\_ #\/ #\ #\ #\_ #\/ #\newline
#\/ #\ #\\ #\ #\ #\. #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\newline
#\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\. #\ #\ #\ #\ #\\ #\newline
#\\ #\ #\ #\ #\ #\ #\ #\. #\ #\ #\/ #\. #\\ #\_ #\/ #\newline
#\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
#\\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\ #\/ #\newline
#\/ #\ #\ #\ #\/ #\ #\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\newline
#\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\_ #\/ #\newline
#\/ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
#\\ #\ #\ #\ #\ #\_ #\/ #\. #\ #\ #\/ #\. #\ #\_ #\/ #\newline
#\/ #\ #\\ #\ #\/ #\. #\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
#\\ #\_ #\/ #\. #\ #\_ #\/ #\. #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\ #\_ #\ #\. #\\ #\_ #\ #\. #\ #\_ #\ #\. #\\ #\newline
#\\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\newline)))
(lambda (nrows ncols) (lambda () (run nrows ncols)))
20
7))
(main)
; maze maze
[-- Attachment #3: trav1_bug.scm --]
[-- Type: application/octet-stream, Size: 5267 bytes --]
(define (run-bench name count ok? run)
(let loop ((i count) (result '(undefined)))
(if (< 0 i)
(loop (- i 1) (run))
result)))
(define (run-benchmark name count ok? run-maker . args)
(newline)
(let* ((run (apply run-maker args))
(result (run-bench name count ok? run)))
(if (not (ok? result))
(begin
(display "*** wrong result ***")
(newline)
(display "*** got: ")
(write result)
(newline)))))
(define (fatal-error . args)
(for-each display args)
(newline)
(exit 1))
(define (call-with-output-file/truncate filename proc)
(call-with-output-file filename proc))
(define trav1-iters 10)
(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 (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)
(define (main . args)
(run-benchmark
"trav1"
trav1-iters
(lambda (result) #t)
(lambda () (lambda () (init-traverse)))))
(main)
; trav1 trav1
[-- Attachment #4: trav2_bug.scm --]
[-- Type: application/octet-stream, Size: 5414 bytes --]
; trav2 trav2
(define-macro (if-fixflo yes no) no)
;------------------------------------------------------------------------------
(define (run-bench name count ok? run)
(let loop ((i count) (result '(undefined)))
(if (< 0 i)
(loop (- i 1) (run))
result)))
(define (run-benchmark name count ok? run-maker . args)
(newline)
(let* ((run (apply run-maker args))
(result (run-bench name count ok? run)))
(if (not (ok? result))
(begin
(display "*** wrong result ***")
(newline)
(display "*** got: ")
(write result)
(newline)))))
(define (fatal-error . args)
(for-each display args)
(newline)
(exit 1))
(define (call-with-output-file/truncate filename proc)
(call-with-output-file filename proc))
(define trav2-iters 2)
(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 (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)
(init-traverse)
(define (main . args)
(run-benchmark
"trav2"
trav2-iters
(lambda (result) #t)
(lambda () (lambda () (run-traverse)))))
(main)
; trav2 trav2
^ permalink raw reply [flat|nested] 8+ messages in thread