Got rid of one-armed ifs in the common benchmarks.
This commit is contained in:
Vincent St-Amour
parent
c1abea82ec
commit
11d8dac0bf
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user