diff --git a/collects/tests/racket/benchmarks/common/dynamic2.sch b/collects/tests/racket/benchmarks/common/dynamic2.sch index c417947215..de63086dc5 100644 --- a/collects/tests/racket/benchmarks/common/dynamic2.sch +++ b/collects/tests/racket/benchmarks/common/dynamic2.sch @@ -7,6 +7,7 @@ ; 970215 / wdc Removed most i/o and added dynamic-benchmark. ; 990707 / lth Added a quote and changed the call to run-benchmark. ; 010404 / wdc Changed the input file path name to "dynamic-input.sch". +; 100404 / Vincent St-Amour Got rid of one-armed ifs ;; Fritz's dynamic type inferencer, set up to run on itself ;; (see the end of this file). @@ -1034,7 +1035,9 @@ (let ((tv-def (tvar-def tv-rep))) (asymm-link! tv-rep dynamic) (if (not (null? tv-def)) - (map equiv-with-dynamic! (type-args tv-def)))))) + (map equiv-with-dynamic! (type-args tv-def)) + #f)) + #f)) '()) ;---------------------------------------------------------------------------- ; Polymorphic type management diff --git a/collects/tests/racket/benchmarks/common/earley.sch b/collects/tests/racket/benchmarks/common/earley.sch index d5f90a238a..649b0c7f3c 100644 --- a/collects/tests/racket/benchmarks/common/earley.sch +++ b/collects/tests/racket/benchmarks/common/earley.sch @@ -2,6 +2,7 @@ ; $Id: earley.sch,v 1.2 1999/07/12 18:05:19 lth Exp $ ; 990708 / lth -- changed 'main' to 'earley-benchmark'. +; 100404 / Vincent St-Amour -- got rid of one-armed ifs ; ; (make-parser grammar lexer) is used to create a parser from the grammar ; description `grammar' and the lexer function `lexer'. @@ -199,7 +200,8 @@ (vector-set! steps i (- i nb-nts)) (vector-set! names i (list (vector-ref nts i) 0)) (vector-set! enders i (list i)) - (nt-loop (- i 1))))) + (nt-loop (- i 1))) + #f)) (let def-loop ((defs grammar) (conf (vector-length nts))) (if (pair? defs) @@ -220,7 +222,8 @@ (vector-set! steps conf (- (ind head nts) nb-nts)) (add-conf conf head nts enders) (rule-loop (cdr rules) (+ conf 1) (+ rule-num 1)))))) - (def-loop (cdr defs) conf)))))))) + (def-loop (cdr defs) conf)))) + #f)))) ; Now, for each non-terminal, compute the starters, enders and predictors and ; the names and steps tables. @@ -309,7 +312,8 @@ (if (< tail 0) (begin (vector-set! conf-set 0 (vector-ref state 0)) - (vector-set! state 0 conf))))) + (vector-set! state 0 conf)) + #f))) (define (conf-set-adjoin* states state-num l i) (let ((state (vector-ref states state-num))) @@ -321,7 +325,8 @@ (begin (conf-set-adjoin state conf-set conf i) (loop (cdr l1))) - (loop (cdr l1)))))))) + (loop (cdr l1)))) + #f)))) (define (conf-set-adjoin** states states* state-num conf i) (let ((state (vector-ref states state-num))) @@ -329,7 +334,8 @@ (let* ((state* (vector-ref states* state-num)) (conf-set* (conf-set-get* state* state-num conf))) (if (not (conf-set-next conf-set* i)) - (conf-set-adjoin state* conf-set* conf i)) + (conf-set-adjoin state* conf-set* conf i) + #f) #t) #f))) @@ -340,7 +346,8 @@ (begin (conf-set-adjoin state conf-set conf i) (loop (conf-set-next other-set i))) - (loop (conf-set-next other-set i)))))) + (loop (conf-set-next other-set i))) + #f))) (define (forw states state-num starters enders predictors steps nts) @@ -357,7 +364,8 @@ (begin (conf-set-adjoin state starter-set starter state-num) (loop1 (cdr l))) - (loop1 (cdr l)))))) + (loop1 (cdr l)))) + #f)) ; check for possible completion of the non-terminal `nt' to the ; right of the dot @@ -370,7 +378,8 @@ (next-set (conf-set-get* state state-num next))) (conf-set-union state next-set next conf-set) (loop2 (cdr l))) - (loop2 (cdr l))))))) + (loop2 (cdr l)))) + #f))) (define (reduce states state state-num conf-set head preds) @@ -386,9 +395,11 @@ (if pred-set (let* ((next (+ pred 1)) (next-set (conf-set-get* state state-num next))) - (conf-set-union state next-set next pred-set))) + (conf-set-union state next-set next pred-set)) + #f) (loop2 (conf-set-next conf-set i))) - (loop1 (cdr l)))))))) + (loop1 (cdr l))))) + #f))) (let ((state (vector-ref states state-num)) (nb-nts (vector-length nts))) @@ -404,7 +415,8 @@ (predict state state-num conf-set conf step starters enders) (let ((preds (vector-ref predictors (+ step nb-nts)))) (reduce states state state-num conf-set head preds))) - (loop))))))) + (loop)) + #f))))) (define (forward starters enders predictors steps nts toks) (let* ((nb-toks (vector-length toks)) @@ -418,7 +430,8 @@ (let ((tok-nts (cdr (vector-ref toks i)))) (conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token (forw states (+ i 1) starters enders predictors steps nts) - (loop (+ i 1))))) + (loop (+ i 1))) + #f)) states)) (define (produce conf i j enders steps toks states states* nb-nts) @@ -438,7 +451,9 @@ (conf-set-adjoin** states states* j ender k)) (loop2 (conf-set-next ender-set k))) (loop1 (cdr l)))) - (loop1 (cdr l))))))))) + (loop1 (cdr l)))) + #f)) + #f))) (define (back states states* state-num enders steps nb-nts toks) (let ((state* (vector-ref states* state-num))) @@ -455,7 +470,8 @@ (produce conf i state-num enders steps toks states states* nb-nts) (loop2 (conf-set-next conf-set i))) - (loop1))))))))) + (loop1)))) + #f))))) (define (backward states enders steps nts toks) (let* ((nb-toks (vector-length toks)) @@ -467,12 +483,14 @@ (if (pair? l) (let ((conf (car l))) (conf-set-adjoin** states states* nb-toks conf 0) - (loop1 (cdr l))))) + (loop1 (cdr l))) + #f)) (let loop2 ((i nb-toks)) (if (>= i 0) (begin (back states states* i enders steps nb-nts toks) - (loop2 (- i 1))))) + (loop2 (- i 1))) + #f)) states*)) (define (parsed? nt i j nts enders states) diff --git a/collects/tests/racket/benchmarks/common/fft.sch b/collects/tests/racket/benchmarks/common/fft.sch index 92ed55d0e1..2ede72878a 100644 --- a/collects/tests/racket/benchmarks/common/fft.sch +++ b/collects/tests/racket/benchmarks/common/fft.sch @@ -5,6 +5,7 @@ ; Created: 8-Apr-85 ; Modified: 6-May-85 09:29:22 (Bob Shaw) ; 11-Aug-87 (Will Clinger) +; 4-May-10 (Vincent St-Amour) ; Language: Scheme ; Status: Public Domain ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -51,7 +52,8 @@ (if (< i n) (begin (set! m (+ m 1)) (set! i (+ i i)) - (loop)))) + (loop)) + #t)) (cond ((not (= n (expt 2 m))) (error "array size not a power of two."))) ;; interchange elements in bit-reversed order diff --git a/collects/tests/racket/benchmarks/common/graphs.sch b/collects/tests/racket/benchmarks/common/graphs.sch index 791aadcbff..1d8b8f43e7 100644 --- a/collects/tests/racket/benchmarks/common/graphs.sch +++ b/collects/tests/racket/benchmarks/common/graphs.sch @@ -2,6 +2,7 @@ ; and to expand the four macros below. ; Modified 11 June 1997 by Will Clinger to eliminate assertions ; and to replace a use of "recur" with a named let. +; Modified 4 May 2010 by Vincent St-Amour to get rid of one-armed ifs ; ; Performance note: (graphs-benchmark 7) allocates ; 34509143 pairs @@ -70,8 +71,9 @@ (let ((x (make-vector size (f 0)))) (let loop ((i 1)) (if (< i size) (begin ; [wdc - was when] - (vector-set! x i (f i)) - (loop (+ i 1))))) + (vector-set! x i (f i)) + (loop (+ i 1))) + #t)) x)))) (define vector-fold @@ -616,7 +618,9 @@ (lambda (t) (if (vector-ref from-m t) (begin ; [wdc - was when] - (vector-set! from-f t #t))))))))))))) + (vector-set! from-f t #t)) + #t)))) + #t))))))) res))) diff --git a/collects/tests/racket/benchmarks/common/maze2.sch b/collects/tests/racket/benchmarks/common/maze2.sch index c9ec094cc6..072e981208 100644 --- a/collects/tests/racket/benchmarks/common/maze2.sch +++ b/collects/tests/racket/benchmarks/common/maze2.sch @@ -12,6 +12,7 @@ ; By Ozan Yigit ;;; Rehacked by Olin 4/1995. +;;; One-armed ifs removed by Vincent St-Amour 5/5/2010 (define (random-state n) (vector n)) @@ -125,7 +126,8 @@ (let ((next (vector-ref x 1))) (cond ((not (eq? r next)) (vector-set! x 1 r) - (lp next)))))) + (lp next))))) + #t) r))))) ; Then return r. (define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2))) @@ -238,7 +240,8 @@ (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)))))) + (if (= (set-size set1) ncells) (quit #f) #t)) + #t))) walls)))) @@ -255,7 +258,8 @@ (set-cell:parent node parent) (do-children (lambda (child) (if (not (eq? child parent)) - (search child node))) + (search child node) + #t)) maze node))) ;;; Move the root to NEW-ROOT. @@ -264,7 +268,7 @@ (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))))) + (if old-parent (lp old-parent node) #t)))) ;;; How far from CELL to the root? @@ -436,10 +440,12 @@ ((<= 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 3) (- y 1)) south-west) + #t) (add-wall hex (href harr x (- y 2)) south) (if (< x xmax) - (add-wall hex (href harr (+ x 3) (- y 1)) south-east))))) + (add-wall hex (href harr (+ x 3) (- y 1)) south-east) + #t)))) ;; 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, @@ -449,14 +455,16 @@ ;; 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 xmax 0) south-east) + #t) (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)))) + (add-wall (href harr x 1) (href harr (+ x 3) 0) south-east))) + #t) (list->vector walls))) @@ -504,28 +512,31 @@ (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)))) + (if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1))) #t) + (if (not (bit-test walls south)) (proc (href harr x (- y 2))) #t) + (if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1))) #t) ;; 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)))) + (if (not (bit-test (cell:walls nw) south-east)) (proc nw) #t)) + #t) ;; 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)))) + (if (not (bit-test (cell:walls n) south)) (proc n) #t)) + #t) ;; 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)))))) + (if (not (bit-test (cell:walls ne) south-west)) (proc ne) #t)) + #t))) @@ -612,7 +623,8 @@ (write-ch (dot/space harr (- nrows 1) (+ c 1))) (write-ch #\\)) (if (odd? ncols) - (write-ch (if (= entrance (- ncols 1)) #\space #\_))) + (write-ch (if (= entrance (- ncols 1)) #\space #\_)) + #t) ; (newline) (write-ch #\newline) diff --git a/collects/tests/racket/benchmarks/common/nqueens.sch b/collects/tests/racket/benchmarks/common/nqueens.sch index 26a6f8513f..e12d6904da 100644 --- a/collects/tests/racket/benchmarks/common/nqueens.sch +++ b/collects/tests/racket/benchmarks/common/nqueens.sch @@ -1,5 +1,6 @@ ;;; NQUEENS -- Compute number of solutions to 8-queens problem. ;; 2006/08 -- renamed `try' to `try-it' to avoid Bigloo collision (mflatt) +;; 2010/04 -- got rid of the one-armed id (stamourv) (define trace? #f) @@ -12,7 +13,7 @@ (define (try-it x y z) (if (null? x) (if (null? y) - (begin (if trace? (begin (write z) (newline))) 1) + (begin (if trace? (begin (write z) (newline)) #t) 1) 0) (+ (if (ok? (car x) 1 z) (try-it (append (cdr x) y) '() (cons (car x) z)) diff --git a/collects/tests/racket/benchmarks/common/scheme2.sch b/collects/tests/racket/benchmarks/common/scheme2.sch index 934b5783ec..01322f7d06 100644 --- a/collects/tests/racket/benchmarks/common/scheme2.sch +++ b/collects/tests/racket/benchmarks/common/scheme2.sch @@ -85,9 +85,11 @@ (define (variable x) (if (not (symbol? x)) - (scheme-error "Identifier expected" x)) + (scheme-error "Identifier expected" x) + #t) (if (memq x scheme-syntactic-keywords) - (scheme-error "Variable name can not be a syntactic keyword" x))) + (scheme-error "Variable name can not be a syntactic keyword" x) + #t)) (define (shape form n) (let loop ((form form) (n n) (l form)) @@ -137,7 +139,8 @@ (comp-quasiquotation-list form (- level 1) env))) ((eq? (car form) 'unquote-splicing) (if (= level 1) - (scheme-error "Ill-placed 'unquote-splicing'" form)) + (scheme-error "Ill-placed 'unquote-splicing'" form) + #t) (comp-quasiquotation-list form (- level 1) env)) (else (comp-quasiquotation-list form level env)))) @@ -268,7 +271,8 @@ (let ((pattern (cadr expr))) (let ((name (if (pair? pattern) (car pattern) pattern))) (if (not (symbol? name)) - (scheme-error "Identifier expected" name)) + (scheme-error "Identifier expected" name) + #t) name))) (define (definition-value expr) @@ -672,7 +676,8 @@ (vector-set! x 3 c) (let loop ((n nb-vars) (x x) (i 4) (l d)) (if (<= i n) - (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))))) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))) + #t)) (body x))))) ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -769,7 +774,8 @@ (vector-set! x 0 rte) (let loop ((x x) (i 1) (l vals)) (if (pair? l) - (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l))))) + (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l))) + #t)) (body x)))) ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/collects/tests/racket/benchmarks/common/triangle.sch b/collects/tests/racket/benchmarks/common/triangle.sch index baeddd2704..700a00a9b0 100644 --- a/collects/tests/racket/benchmarks/common/triangle.sch +++ b/collects/tests/racket/benchmarks/common/triangle.sch @@ -29,7 +29,8 @@ (cond ((= depth 14) (let ((lp (last-position))) (if (not (member lp *final*)) - (set! *final* (cons lp *final*)))) + (set! *final* (cons lp *final*)) + #t)) (set! *answer* (cons (cdr (vector->list *sequence*)) *answer*)) #t)