conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

apply R6RS -> R7RS patch supplied by @SaitoAtsushi.

This commit is contained in:
Sunrin SHIMURA (keen) 2015-01-18 04:30:54 +00:00
parent cd94f5b554
commit 5ba9154265
57 changed files with 766 additions and 709 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

207
etc/R7RS/bench
View File

@ -1,4 +1,4 @@
#! /usr/bin/env bash #!/usr/bin/env bash
# For running R6RS benchmarks. # For running R6RS benchmarks.
# #
@ -34,23 +34,23 @@ HOME="`( pwd )`"
SRC="${HOME}/src" SRC="${HOME}/src"
INPUTS="${HOME}/inputs" INPUTS="${HOME}/inputs"
TEMP="/tmp/larcenous" # TEMP="/tmp/larcenous"
################################################################ ################################################################
GABRIEL_BENCHMARKS="browse deriv dderiv destruc diviter divrec puzzle triangl tak takl ntakl cpstak ctak" GABRIEL_BENCHMARKS="browse deriv destruc diviter divrec puzzle triangl tak takl ntakl cpstak ctak"
NUM_BENCHMARKS="fib fibc fibfp sum sumfp fft mbrot mbrotZ nucleic pnpoly" NUM_BENCHMARKS="fib fibc sum sumfp fft mbrot mbrotZ nucleic pnpoly"
KVW_BENCHMARKS="ack array1 string sum1 cat cat2 cat3 tail wc" KVW_BENCHMARKS="ack array1 string sum1 cat tail wc"
IO_BENCHMARKS="read0 read1 read2 read3" IO_BENCHMARKS="read1"
OTHER_BENCHMARKS="bibfreq bibfreq2 compiler conform dynamic earley graphs lattice matrix maze mazefun nqueens paraffins parsing peval pi primes quicksort ray scheme simplex slatex" OTHER_BENCHMARKS="compiler conform dynamic earley graphs lattice matrix mazefun nqueens paraffins parsing peval pi primes quicksort ray scheme simplex slatex"
GC_BENCHMARKS="nboyer sboyer gcbench mperm" GC_BENCHMARKS="nboyer sboyer gcbench mperm"
SYNTH_BENCHMARKS="equal normalization bv2string listsort vecsort hashtable0" SYNTH_BENCHMARKS="equal"
ALL_BENCHMARKS="$GABRIEL_BENCHMARKS $NUM_BENCHMARKS $KVW_BENCHMARKS $IO_BENCHMARKS $OTHER_BENCHMARKS $GC_BENCHMARKS $SYNTH_BENCHMARKS" ALL_BENCHMARKS="$GABRIEL_BENCHMARKS $NUM_BENCHMARKS $KVW_BENCHMARKS $IO_BENCHMARKS $OTHER_BENCHMARKS $GC_BENCHMARKS $SYNTH_BENCHMARKS"
@ -91,13 +91,11 @@ setup ()
# For both Solaris and Linux machines. # For both Solaris and Linux machines.
LARCENY=${LARCENY:-"../../../larceny"} SAGITTARIUS=${SAGITTARIUS:-"sash"}
PETIT=${PETIT:-"../../../petit-larceny"} GAUCHE=${GAUCHE:-"gosh"}
PLTR6RS=${PLTR6RS:-"plt-r6rs"} FOMENT=${FOMENT:-"foment"}
YPSILON=${YPSILON:-"ypsilon"} HUSK=${HUSK:-"huski"}
MOSH=${MOSH:-"mosh"} CHIBI=${CHIBI:-"chibi-scheme"}
PETITE=${PETITE:-"petite"}
} }
setup setup
@ -112,13 +110,8 @@ Usage: bench [-r runs] <system> <benchmark>
<system> is the abbreviated name of the implementation to benchmark: <system> is the abbreviated name of the implementation to benchmark:
ikarus for Ikarus sagittarius for Sagittarius Scheme
larceny for Larceny gauche for Gauche Scheme
mosh for Mosh
petit for Petit Larceny
petite for Petite Chez
plt for PLT Scheme
ypsilon for Ypsilon
all for all of the above all for all of the above
<benchmark> is the name of the benchmark(s) to run: <benchmark> is the name of the benchmark(s) to run:
@ -161,128 +154,82 @@ evaluate ()
{ {
echo echo
echo Testing $1 under ${NAME} echo Testing $1 under ${NAME}
make_src_code $1
echo Compiling... echo Compiling...
$COMP "${TEMP}/$1.${EXTENSION}" # $COMP "${TEMP}/$1.${EXTENSION}"
i=0 i=0
while [ "$i" -lt "$NB_RUNS" ] while [ "$i" -lt "$NB_RUNS" ]
do do
echo Running... echo Running...
$EXEC "${TEMP}/$1.${EXTENSIONCOMP}" "${INPUTS}/$1.input" $EXEC "${SRC}/$1.sch" "${INPUTS}/$1.input"
i=`expr $i + 1` i=`expr $i + 1`
done done
} 2>&1 | tee -a results.${NAME} } 2>&1 | tee -a results.${NAME}
} }
make_src_code ()
{
cat "${SRC}/$1.sch" "${SRC}/common.sch" > "${TEMP}/$1.${EXTENSION}"
}
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
# Definitions specific to Larceny and Petit Larceny # Definitions specific to Sagittarius Scheme
#
# The --nocontract command-line option reduces variability
# of timing, and probably corresponds to the default for
# most other systems.
larceny_comp () sagittarius_comp ()
{
echo "(import (larceny compiler)) (compile-file \"$1\")" \
| time "${LARCENY}" -err5rs -- -e "(repl-prompt values)"
}
larceny_exec ()
{
time "${LARCENY}" --nocontract --r6rs --program "$1" < "$2"
}
petit_comp ()
{
echo "(import (larceny compiler)) (compile-file \"$1\")" \
| time "${PETIT}" -err5rs -- -e "(repl-prompt values)"
}
petit_exec ()
{
time "${PETIT}" --nocontract --r6rs --program "$1" < "$2"
}
henchman_comp ()
{
echo "(import (larceny compiler)) (compile-file \"$1\")" \
| time "${HENCHMAN}" -err5rs -- -e "(repl-prompt values)"
}
henchman_exec ()
{
time "${HENCHMAN}" --nocontract --r6rs --program "$1" < "$2"
}
# -----------------------------------------------------------------------------
# Definitions specific to Ikarus
ikarus_comp ()
{ {
: :
} }
ikarus_exec () sagittarius_exec ()
{ {
time "${IKARUS}" --r6rs-script "$1" < "$2" time "${SAGITTARIUS}" -t -n "$1" < "$2"
} }
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
# Definitions specific to PLT Scheme # Definitions specific to Gauche Scheme
plt_comp () gauche_comp ()
{
echo | time "${PLTR6RS}" --compile "$1"
}
plt_exec ()
{
time "${PLTR6RS}" "$1" < "$2"
}
# -----------------------------------------------------------------------------
# Definitions specific to Ypsilon
ypsilon_comp ()
{ {
: :
} }
ypsilon_exec () gauche_exec ()
{ {
time "${YPSILON}" "$1" < "$2" time "${GAUCHE}" -I. -r7 "$1" < "$2"
} }
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
# Definitions specific to Mosh # Definitions specific to Foment
mosh_comp () foment_comp ()
{ {
: :
} }
mosh_exec () foment_exec ()
{ {
time "${MOSH}" "$1" < "$2" time "${FOMENT}" "$1" < "$2"
} }
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
# Definitions specific to Petite Chez # Definitions specific to Husk Scheme
petite_comp () husk_comp ()
{ {
: :
} }
petite_exec () husk_exec ()
{ {
time "${PETITE}" --optimize-level 2 --program "$1" < "$2" time "${HUSK}" "$1" < "$2"
}
# -----------------------------------------------------------------------------
# Definitions specific to Chibi Scheme
chibi_comp ()
{
:
}
chibi_exec ()
{
time "${CHIBI}" "$1" < "$2"
} }
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
@ -329,39 +276,9 @@ for system in $systems ; do
case "$system" in case "$system" in
larceny) NAME='Larceny' sagittarius)NAME='Sagittarius'
COMP=larceny_comp COMP=sagittarius_comp
EXEC=larceny_exec EXEC=sagittarius_exec
COMPOPTS=""
EXTENSION="sch"
EXTENSIONCOMP="slfasl"
COMPCOMMANDS=""
EXECCOMMANDS=""
;;
petit) NAME='PetitLarceny'
COMP=petit_comp
EXEC=petit_exec
COMPOPTS=""
EXTENSION="sch"
EXTENSIONCOMP="slfasl"
COMPCOMMANDS=""
EXECCOMMANDS=""
;;
henchman) NAME='Henchman'
COMP=henchman_comp
EXEC=henchman_exec
COMPOPTS=""
EXTENSION="sch"
EXTENSIONCOMP="slfasl"
COMPCOMMANDS=""
EXECCOMMANDS=""
;;
ikarus) NAME='Ikarus'
COMP=ikarus_comp
EXEC=ikarus_exec
COMPOPTS="" COMPOPTS=""
EXTENSION="sch" EXTENSION="sch"
EXTENSIONCOMP="sch" EXTENSIONCOMP="sch"
@ -369,9 +286,9 @@ for system in $systems ; do
EXECCOMMANDS="" EXECCOMMANDS=""
;; ;;
plt) NAME='PLT' gauche)NAME='Gauche'
COMP=plt_comp COMP=gauche_comp
EXEC=plt_exec EXEC=gauche_exec
COMPOPTS="" COMPOPTS=""
EXTENSION="sch" EXTENSION="sch"
EXTENSIONCOMP="sch" EXTENSIONCOMP="sch"
@ -379,9 +296,9 @@ for system in $systems ; do
EXECCOMMANDS="" EXECCOMMANDS=""
;; ;;
ypsilon) NAME='Ypsilon' # copied from Ikarus' settings... chibi)NAME='Chibi'
COMP=ypsilon_comp COMP=chibi_comp
EXEC=ypsilon_exec EXEC=chibi_exec
COMPOPTS="" COMPOPTS=""
EXTENSION="sch" EXTENSION="sch"
EXTENSIONCOMP="sch" EXTENSIONCOMP="sch"
@ -389,9 +306,9 @@ for system in $systems ; do
EXECCOMMANDS="" EXECCOMMANDS=""
;; ;;
mosh) NAME='Mosh' foment)NAME='Foment'
COMP=mosh_comp COMP=foment_comp
EXEC=mosh_exec EXEC=foment_exec
COMPOPTS="" COMPOPTS=""
EXTENSION="sch" EXTENSION="sch"
EXTENSIONCOMP="sch" EXTENSIONCOMP="sch"
@ -399,9 +316,9 @@ for system in $systems ; do
EXECCOMMANDS="" EXECCOMMANDS=""
;; ;;
petite) NAME='Petite' husk)NAME='Husk'
COMP=petite_comp COMP=husk_comp
EXEC=petite_exec EXEC=husk_exec
COMPOPTS="" COMPOPTS=""
EXTENSION="sch" EXTENSION="sch"
EXTENSIONCOMP="sch" EXTENSIONCOMP="sch"
@ -417,7 +334,7 @@ for system in $systems ; do
echo Benchmarking ${NAME} on `date` under `uname -a` echo Benchmarking ${NAME} on `date` under `uname -a`
} >> results.${NAME} } >> results.${NAME}
mkdir "${TEMP}" # mkdir "${TEMP}"
for program in $benchmarks ; do for program in $benchmarks ; do
evaluate $program evaluate $program

28
etc/R7RS/inputs/browse.input
View File

@ -3,16 +3,18 @@
(*a *b *b *a (*a) (*b)) (*a *b *b *a (*a) (*b))
(? ? * (b a) * ? ?)) (? ? * (b a) * ? ?))
(\x38;37 \x31;77 \x31;090 \x36;17 \x36;61 \x37;49 \x36;28 \x35;6 (|\x38;37| |\x31;77| |\x31;090| |\x36;17| |\x36;61| |\x37;49| |\x36;28|
\x38;26 \x34;08 \x31;035 \x34;74 \x33;20 \x34;52 \x36;72 \x39;91 |\x35;6| |\x38;26| |\x34;08| |\x31;035| |\x34;74| |\x33;20| |\x34;52|
\x31;55 \x31;22 \x37;93 \x32;21 \x37;16 \x37;27 \x38;48 \x33;09 |\x36;72| |\x39;91| |\x31;55| |\x31;22| |\x37;93| |\x32;21| |\x37;16|
\x31;44 \x39;36 \x31;00 \x38;81 \x32;87 \x34;30 \x32;3 \x37;71 |\x37;27| |\x38;48| |\x33;09| |\x31;44| |\x39;36| |\x31;00| |\x38;81|
\x32;32 \x38;04 \x39;58 \x36;50 \x31;068 \x31;057 \x34;63 \x32;76 |\x32;87| |\x34;30| |\x32;3| |\x37;71| |\x32;32| |\x38;04| |\x39;58|
\x31;046 \x31;002 \x31;99 \x33;4 \x37;38 \x32;10 \x35;40 \x33;97 |\x36;50| |\x31;068| |\x31;057| |\x34;63| |\x32;76| |\x31;046| |\x31;002|
\x33;42 \x33;64 \x37;82 \x36;83 \x38;9 \x33;75 \x31;66 \x35;95 |\x31;99| |\x33;4| |\x37;38| |\x32;10| |\x35;40| |\x33;97| |\x33;42|
\x38;92 \x37;05 \x35;07 \x36;39 \x33;31 \x31;88 \x32;43 \x34;41 |\x33;64| |\x37;82| |\x36;83| |\x38;9| |\x33;75| |\x31;66| |\x35;95|
\x31;013 \x31;079 \x36;7 \x32;98 \x33;86 \x35;73 \x38;59 \x31;33 |\x38;92| |\x37;05| |\x35;07| |\x36;39| |\x33;31| |\x31;88| |\x32;43|
\x37;60 \x31;2 \x35;29 \x38;15 \x31;11 \x34;96 \x34;5 \x32;65 |\x34;41| |\x31;013| |\x31;079| |\x36;7| |\x32;98| |\x33;86| |\x35;73|
\x39;25 \x39;03 \x32;54 \x37;8 \x35;51 \x36;06 \x34;85 \x35;18 |\x38;59| |\x31;33| |\x37;60| |\x31;2| |\x35;29| |\x38;15| |\x31;11|
\x34;19 \x38;70 \x35;62 \x31; \x33;53 \x39;80 \x36;94 \x39;14 |\x34;96| |\x34;5| |\x32;65| |\x39;25| |\x39;03| |\x32;54| |\x37;8|
\x39;69 \x39;47 \x35;84 \x31;024) |\x35;51| |\x36;06| |\x34;85| |\x35;18| |\x34;19| |\x38;70| |\x35;62|
|\x31;| |\x33;53| |\x39;80| |\x36;94| |\x39;14| |\x39;69| |\x39;47|
|\x35;84| |\x31;024|)

4
etc/R7RS/inputs/dynamic.data
View File

@ -45,7 +45,7 @@
(define (binding-show binding) (define (binding-show binding)
; returns a printable representation of a type binding ; returns a printable representation of a type binding
(cons (key-show (binding-key binding)) (cons (key-show (binding-key binding))
(cons ': (value-show (binding-value binding))))) (cons '|:| (value-show (binding-value binding)))))
; environments ; environments
@ -2281,7 +2281,7 @@
; displays the top level environment ; displays the top level environment
(map (lambda (binding) (map (lambda (binding)
(cons (key-show (binding-key binding)) (cons (key-show (binding-key binding))
(cons ': (tvar-show (binding-value binding))))) (cons '|:| (tvar-show (binding-value binding)))))
(env->list dynamic-top-level-env))) (env->list dynamic-top-level-env)))
; ---------------------------------------------------------------------------- ; ----------------------------------------------------------------------------
; Dynamic type inference for Scheme ; Dynamic type inference for Scheme

9
etc/R7RS/src/ack.sch
View File

@ -1,7 +1,8 @@
;;; ACK -- One of the Kernighan and Van Wyk benchmarks. ;;; ACK -- One of the Kernighan and Van Wyk benchmarks.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define (ack m n) (define (ack m n)
(cond ((= m 0) (+ n 1)) (cond ((= m 0) (+ n 1))
@ -16,8 +17,10 @@
(s2 (number->string input2)) (s2 (number->string input2))
(s1 (number->string input1)) (s1 (number->string input1))
(name "ack")) (name "ack"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (ack (hide count input1) (hide count input2))) (lambda () (ack (hide count input1) (hide count input2)))
(lambda (result) (= result output))))) (lambda (result) (= result output)))))
(include "src/common.sch")

10
etc/R7RS/src/array1.sch
View File

@ -1,8 +1,8 @@
;;; ARRAY1 -- One of the Kernighan and Van Wyk benchmarks. ;;; ARRAY1 -- One of the Kernighan and Van Wyk benchmarks.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme write)
(rnrs io simple)) (scheme read))
(define (create-x n) (define (create-x n)
(define result (make-vector n)) (define result (make-vector n))
@ -34,8 +34,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "array1")) (name "array1"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
1 1
(lambda () (go (hide count count) (hide count input1))) (lambda () (go (hide count count) (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

14
etc/R7RS/src/browse.sch
View File

@ -1,11 +1,11 @@
;;; BROWSE -- Benchmark to create and browse through ;;; BROWSE -- Benchmark to create and browse through
;;; an AI-like data base of units. ;;; an AI-like data base of units.
(import (rnrs base) (import (scheme base)
(rnrs lists) (scheme read)
(rnrs control) (scheme write))
(rnrs io simple)
(rnrs mutable-pairs)) (define mod modulo)
(define (lookup key table) (define (lookup key table)
(let loop ((x table)) (let loop ((x table))
@ -200,8 +200,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 "") (s1 "")
(name "browse")) (name "browse"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (browse (hide count input1))) (lambda () (browse (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

11
etc/R7RS/src/cat.sch
View File

@ -1,9 +1,10 @@
;;; CAT -- One of the Kernighan and Van Wyk benchmarks. ;;; CAT -- One of the Kernighan and Van Wyk benchmarks.
;;; Rewritten by Will Clinger into more idiomatic Scheme. ;;; Rewritten by Will Clinger into more idiomatic Scheme.
(import (rnrs base) (import (scheme base)
(rnrs io simple) (scheme read)
(rnrs files)) (scheme file)
(scheme write))
(define (catport in out) (define (catport in out)
(let ((x (read-char in))) (let ((x (read-char in)))
@ -32,8 +33,10 @@
(s2 input2) (s2 input2)
(s1 input1) (s1 input1)
(name "cat")) (name "cat"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s3) (string-append name ":" s3)
count count
(lambda () (go (hide count input1) (hide count input2))) (lambda () (go (hide count input1) (hide count input2)))
(lambda (result) #t)))) (lambda (result) #t))))
(include "src/common.sch")

2
etc/R7RS/src/common.sch
View File

@ -24,7 +24,7 @@
;;; provide timings for the benchmark proper (without startup ;;; provide timings for the benchmark proper (without startup
;;; and compile time). ;;; and compile time).
(define (run-r6rs-benchmark name count thunk ok?) (define (run-r7rs-benchmark name count thunk ok?)
(display "Running ") (display "Running ")
(display name) (display name)
(newline) (newline)

19
etc/R7RS/src/compiler.sch
View File

@ -1,8 +1,19 @@
;(define integer->char ascii->char) ;(define integer->char ascii->char)
;(define char->integer char->ascii) ;(define char->integer char->ascii)
(import (rnrs) (rnrs mutable-pairs) (rnrs mutable-strings)) (import (scheme base)
(scheme cxr)
(scheme read)
(scheme file)
(scheme char)
(scheme write))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (syntax-error "Not support this implementation.")))
(define mod modulo)
(define div quotient)
(define open-input-file* open-input-file) (define open-input-file* open-input-file)
(define (pp-expression expr port) (write expr port) (newline port)) (define (pp-expression expr port) (write expr port) (newline port))
(define (write-returning-len obj port) (write obj port) 1) (define (write-returning-len obj port) (write obj port) 1)
@ -841,7 +852,7 @@
(loop (cdr l)))) (loop (cdr l))))
(declaration-value name element default (env-parent-ref decls)))))) (declaration-value name element default (env-parent-ref decls))))))
(define namespace-sym (define namespace-sym
(let ([s (string->canonical-symbol "NAMESPACE")]) (let ((s (string->canonical-symbol "NAMESPACE")))
(define-namable-string-decl s) (define-namable-string-decl s)
s)) s))
(define (node-parent x) (vector-ref x 1)) (define (node-parent x) (vector-ref x 1))
@ -11144,10 +11155,12 @@
(output (read)) (output (read))
(s (number->string count)) (s (number->string count))
(name "compiler")) (name "compiler"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s) (string-append name ":" s)
count count
(lambda () (lambda ()
(ce (hide count input1) (hide count input2) (hide count input3)) (ce (hide count input1) (hide count input2) (hide count input3))
(asm-output-get)) (asm-output-get))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

12
etc/R7RS/src/conform.sch
View File

@ -1,10 +1,8 @@
;;; CONFORM -- Type checker, written by Jim Miller. ;;; CONFORM -- Type checker, written by Jim Miller.
(import (rnrs base) (import (scheme base)
(rnrs unicode) (scheme read)
(rnrs lists) (scheme write))
(rnrs io simple)
(rnrs mutable-pairs))
;;; Functional and unstable ;;; Functional and unstable
@ -462,8 +460,10 @@
(output (read)) (output (read))
(s (number->string count)) (s (number->string count))
(name "conform")) (name "conform"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s) (string-append name ":" s)
count count
(lambda () (apply test input1)) (lambda () (apply test input1))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

9
etc/R7RS/src/cpstak.sch
View File

@ -1,8 +1,9 @@
;;; CPSTAK -- A continuation-passing version of the TAK benchmark. ;;; CPSTAK -- A continuation-passing version of the TAK benchmark.
;;; A good test of first class procedures and tail recursion. ;;; A good test of first class procedures and tail recursion.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define (cpstak x y z) (define (cpstak x y z)
@ -36,9 +37,11 @@
(s2 (number->string input2)) (s2 (number->string input2))
(s1 (number->string input1)) (s1 (number->string input1))
(name "cpstak")) (name "cpstak"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3 ":" s4) (string-append name ":" s1 ":" s2 ":" s3 ":" s4)
count count
(lambda () (lambda ()
(cpstak (hide count input1) (hide count input2) (hide count input3))) (cpstak (hide count input1) (hide count input2) (hide count input3)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

9
etc/R7RS/src/ctak.sch
View File

@ -1,7 +1,8 @@
;;; CTAK -- A version of the TAK procedure that uses continuations. ;;; CTAK -- A version of the TAK procedure that uses continuations.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define (ctak x y z) (define (ctak x y z)
(call-with-current-continuation (call-with-current-continuation
@ -32,9 +33,11 @@
(s2 (number->string input2)) (s2 (number->string input2))
(s1 (number->string input1)) (s1 (number->string input1))
(name "ctak")) (name "ctak"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3 ":" s4) (string-append name ":" s1 ":" s2 ":" s3 ":" s4)
count count
(lambda () (lambda ()
(ctak (hide count input1) (hide count input2) (hide count input3))) (ctak (hide count input1) (hide count input2) (hide count input3)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

10
etc/R7RS/src/deriv.sch
View File

@ -1,7 +1,9 @@
;;; DERIV -- Symbolic derivation. ;;; DERIV -- Symbolic derivation.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write)
(scheme cxr))
;;; Returns the wrong answer for quotients. ;;; Returns the wrong answer for quotients.
;;; Fortunately these aren't used in the benchmark. ;;; Fortunately these aren't used in the benchmark.
@ -40,8 +42,10 @@
(output (read)) (output (read))
(s (number->string count)) (s (number->string count))
(name "deriv")) (name "deriv"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s) (string-append name ":" s)
count count
(lambda () (deriv (hide count input1))) (lambda () (deriv (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

13
etc/R7RS/src/destruc.sch
View File

@ -1,9 +1,10 @@
;;; DESTRUC -- Destructive operation benchmark. ;;; DESTRUC -- Destructive operation benchmark.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple) (scheme write))
(rnrs mutable-pairs))
(define div quotient)
(define (append-to-tail! x y) (define (append-to-tail! x y)
(if (null? x) (if (null? x)
@ -55,9 +56,11 @@
(s2 (number->string input2)) (s2 (number->string input2))
(s1 (number->string input1)) (s1 (number->string input1))
(name "destruc")) (name "destruc"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3) (string-append name ":" s1 ":" s2 ":" s3)
count count
(lambda () (lambda ()
(destructive (hide count input1) (hide count input2))) (destructive (hide count input1) (hide count input2)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

10
etc/R7RS/src/diviter.sch
View File

@ -1,8 +1,8 @@
;;; DIVITER -- Benchmark which divides by 2 using lists of n ()'s. ;;; DIVITER -- Benchmark which divides by 2 using lists of n ()'s.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple)) (scheme write))
(define (create-n n) (define (create-n n)
(do ((n n (- n 1)) (do ((n n (- n 1))
@ -22,9 +22,11 @@
(s1 (number->string input1)) (s1 (number->string input1))
(ll (create-n (hide count input1))) (ll (create-n (hide count input1)))
(name "diviter")) (name "diviter"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (lambda ()
(iterative-div2 ll)) (iterative-div2 ll))
(lambda (result) (equal? (length result) output))))) (lambda (result) (equal? (length result) output)))))
(include "src/common.sch")

10
etc/R7RS/src/divrec.sch
View File

@ -1,8 +1,8 @@
;;; DIVREC -- Benchmark which divides by 2 using lists of n ()'s. ;;; DIVREC -- Benchmark which divides by 2 using lists of n ()'s.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple)) (scheme write))
(define (create-n n) (define (create-n n)
(do ((n n (- n 1)) (do ((n n (- n 1))
@ -21,9 +21,11 @@
(s1 (number->string input1)) (s1 (number->string input1))
(ll (create-n (hide count input1))) (ll (create-n (hide count input1)))
(name "divrec")) (name "divrec"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (lambda ()
(recursive-div2 ll)) (recursive-div2 ll))
(lambda (result) (equal? (length result) output))))) (lambda (result) (equal? (length result) output)))))
(include "src/common.sch")

116
etc/R7RS/src/dynamic.sch
View File

@ -1,7 +1,9 @@
(import (rnrs base)
(rnrs lists) (import (scheme base)
(rnrs io simple) (scheme file)
(rnrs mutable-pairs)) (scheme read)
(scheme write)
(scheme cxr))
;;; DYNAMIC -- Obtained from Andrew Wright. ;;; DYNAMIC -- Obtained from Andrew Wright.
@ -131,7 +133,7 @@
((pair? e) ((pair? e)
(dynamic-parse-action-pair-const (dynamic-parse-datum (car e)) (dynamic-parse-action-pair-const (dynamic-parse-datum (car e))
(dynamic-parse-datum (cdr e)))) (dynamic-parse-datum (cdr e))))
(else (error 'dynamic-parse-datum "Unknown datum: ~s" e)))) (else (error "Unknown datum: " e))))
; VarDef ; VarDef
@ -145,13 +147,13 @@
(if (symbol? e) (if (symbol? e)
(cond (cond
((memq e syntactic-keywords) ((memq e syntactic-keywords)
(error 'dynamic-parse-formal "Illegal identifier (keyword): ~s" e)) (error "Illegal identifier (keyword): " e))
((dynamic-lookup e f-env) ((dynamic-lookup e f-env)
(error 'dynamic-parse-formal "Duplicate variable definition: ~s" e)) (error "Duplicate variable definition: " e))
(else (let ((dynamic-parse-action-result (dynamic-parse-action-var-def e))) (else (let ((dynamic-parse-action-result (dynamic-parse-action-var-def e)))
(cons (gen-binding e dynamic-parse-action-result) (cons (gen-binding e dynamic-parse-action-result)
dynamic-parse-action-result)))) dynamic-parse-action-result))))
(error 'dynamic-parse-formal "Not an identifier: ~s" e))) (error "Not an identifier: " e)))
; dynamic-parse-formal* ; dynamic-parse-formal*
@ -177,7 +179,7 @@
(extend-env-with-binding f-env binding) (extend-env-with-binding f-env binding)
(cons var-result results) (cons var-result results)
(cdr formals)))) (cdr formals))))
(else (error 'dynamic-parse-formal* "Illegal formals: ~s" formals)))))) (else (error "Illegal formals: " formals))))))
(let ((renv-rres (pf* dynamic-empty-env '() formals))) (let ((renv-rres (pf* dynamic-empty-env '() formals)))
(cons (car renv-rres) (reverse (cdr renv-rres)))))) (cons (car renv-rres) (reverse (cdr renv-rres))))))
@ -251,7 +253,7 @@
(cond (cond
((null? es) results) ((null? es) results)
((pair? es) (pe* (cons (dynamic-parse-expression env (car es)) results) (cdr es))) ((pair? es) (pe* (cons (dynamic-parse-expression env (car es)) results) (cdr es)))
(else (error 'dynamic-parse-expression* "Not a list of expressions: ~s" es)))))) (else (error "Not a list of expressions: " es))))))
(reverse (pe* '() exprs)))) (reverse (pe* '() exprs))))
@ -266,7 +268,7 @@
(fst-res (dynamic-parse-expression env fst-expr)) (fst-res (dynamic-parse-expression env fst-expr))
(rem-res (dynamic-parse-expressions env rem-exprs))) (rem-res (dynamic-parse-expressions env rem-exprs)))
(dynamic-parse-action-pair-arg fst-res rem-res))) (dynamic-parse-action-pair-arg fst-res rem-res)))
(else (error 'dynamic-parse-expressions "Illegal expression list: ~s" (else (error "Illegal expression list: "
exprs)))) exprs))))
@ -275,12 +277,12 @@
(define (dynamic-parse-variable env e) (define (dynamic-parse-variable env e)
(if (symbol? e) (if (symbol? e)
(if (memq e syntactic-keywords) (if (memq e syntactic-keywords)
(error 'dynamic-parse-variable "Illegal identifier (keyword): ~s" e) (error "Illegal identifier (keyword): " e)
(let ((assoc-var-def (dynamic-lookup e env))) (let ((assoc-var-def (dynamic-lookup e env)))
(if assoc-var-def (if assoc-var-def
(dynamic-parse-action-variable (binding-value assoc-var-def)) (dynamic-parse-action-variable (binding-value assoc-var-def))
(dynamic-parse-action-identifier e)))) (dynamic-parse-action-identifier e))))
(error 'dynamic-parse-variable "Not an identifier: ~s" e))) (error "Not an identifier: " e)))
; dynamic-parse-procedure-call ; dynamic-parse-procedure-call
@ -296,7 +298,7 @@
(define (dynamic-parse-quote env args) (define (dynamic-parse-quote env args)
(if (list-of-1? args) (if (list-of-1? args)
(dynamic-parse-datum (car args)) (dynamic-parse-datum (car args))
(error 'dynamic-parse-quote "Not a datum (multiple arguments): ~s" args))) (error "Not a datum (multiple arguments): " args)))
; dynamic-parse-lambda ; dynamic-parse-lambda
@ -311,7 +313,7 @@
(dynamic-parse-action-lambda-expression (dynamic-parse-action-lambda-expression
fresults fresults
(dynamic-parse-body (extend-env-with-env env nenv) body))) (dynamic-parse-body (extend-env-with-env env nenv) body)))
(error 'dynamic-parse-lambda "Illegal formals/body: ~s" args))) (error "Illegal formals/body: " args)))
; dynamic-parse-body ; dynamic-parse-body
@ -353,7 +355,7 @@
#f)) #f))
(if (pair? body) (if (pair? body)
(dynamic-parse-command* (def-var* env body) body) (dynamic-parse-command* (def-var* env body) body)
(error 'dynamic-parse-body "Illegal body: ~s" body))) (error "Illegal body: " body)))
; dynamic-parse-if ; dynamic-parse-if
@ -369,7 +371,7 @@
(dynamic-parse-expression env (car args)) (dynamic-parse-expression env (car args))
(dynamic-parse-expression env (cadr args)) (dynamic-parse-expression env (cadr args))
(dynamic-parse-action-empty))) (dynamic-parse-action-empty)))
(else (error 'dynamic-parse-if "Not an if-expression: ~s" args)))) (else (error "Not an if-expression: " args))))
; dynamic-parse-set ; dynamic-parse-set
@ -379,7 +381,7 @@
(dynamic-parse-action-assignment (dynamic-parse-action-assignment
(dynamic-parse-variable env (car args)) (dynamic-parse-variable env (car args))
(dynamic-parse-expression env (cadr args))) (dynamic-parse-expression env (cadr args)))
(error 'dynamic-parse-set "Not a variable/expression pair: ~s" args))) (error "Not a variable/expression pair: " args)))
; dynamic-parse-begin ; dynamic-parse-begin
@ -397,7 +399,7 @@
(map (lambda (e) (map (lambda (e)
(dynamic-parse-cond-clause env e)) (dynamic-parse-cond-clause env e))
args)) args))
(error 'dynamic-parse-cond "Not a list of cond-clauses: ~s" args))) (error "Not a list of cond-clauses: " args)))
; dynamic-parse-cond-clause ; dynamic-parse-cond-clause
@ -409,7 +411,7 @@
(dynamic-parse-action-empty) (dynamic-parse-action-empty)
(dynamic-parse-expression env (car e))) (dynamic-parse-expression env (car e)))
(dynamic-parse-body env (cdr e))) (dynamic-parse-body env (cdr e)))
(error 'dynamic-parse-cond-clause "Not a cond-clause: ~s" e))) (error "Not a cond-clause: " e)))
; dynamic-parse-and ; dynamic-parse-and
@ -418,7 +420,7 @@
(if (list? args) (if (list? args)
(dynamic-parse-action-and-expression (dynamic-parse-action-and-expression
(dynamic-parse-expression* env args)) (dynamic-parse-expression* env args))
(error 'dynamic-parse-and "Not a list of arguments: ~s" args))) (error "Not a list of arguments: " args)))
; dynamic-parse-or ; dynamic-parse-or
@ -427,7 +429,7 @@
(if (list? args) (if (list? args)
(dynamic-parse-action-or-expression (dynamic-parse-action-or-expression
(dynamic-parse-expression* env args)) (dynamic-parse-expression* env args))
(error 'dynamic-parse-or "Not a list of arguments: ~s" args))) (error "Not a list of arguments: " args)))
; dynamic-parse-case ; dynamic-parse-case
@ -439,7 +441,7 @@
(map (lambda (e) (map (lambda (e)
(dynamic-parse-case-clause env e)) (dynamic-parse-case-clause env e))
(cdr args))) (cdr args)))
(error 'dynamic-parse-case "Not a list of clauses: ~s" args))) (error "Not a list of clauses: " args)))
; dynamic-parse-case-clause ; dynamic-parse-case-clause
@ -451,9 +453,9 @@
(list (dynamic-parse-action-empty))) (list (dynamic-parse-action-empty)))
((list? (car e)) ((list? (car e))
(map dynamic-parse-datum (car e))) (map dynamic-parse-datum (car e)))
(else (error 'dynamic-parse-case-clause "Not a datum list: ~s" (car e)))) (else (error "Not a datum list: " (car e))))
(dynamic-parse-body env (cdr e))) (dynamic-parse-body env (cdr e)))
(error 'dynamic-parse-case-clause "Not case clause: ~s" e))) (error "Not case clause: " e)))
; dynamic-parse-let ; dynamic-parse-let
@ -463,7 +465,7 @@
(if (symbol? (car args)) (if (symbol? (car args))
(dynamic-parse-named-let env args) (dynamic-parse-named-let env args)
(dynamic-parse-normal-let env args)) (dynamic-parse-normal-let env args))
(error 'dynamic-parse-let "Illegal bindings/body: ~s" args))) (error "Illegal bindings/body: " args)))
; dynamic-parse-normal-let ; dynamic-parse-normal-let
@ -498,7 +500,7 @@
(dynamic-parse-body (extend-env-with-env (dynamic-parse-body (extend-env-with-env
(extend-env-with-binding env vbind) (extend-env-with-binding env vbind)
nenv) body))) nenv) body)))
(error 'dynamic-parse-named-let "Illegal named let-expression: ~s" args))) (error "Illegal named let-expression: " args)))
; dynamic-parse-parallel-bindings ; dynamic-parse-parallel-bindings
@ -515,8 +517,7 @@
(exprs-asg (exprs-asg
(dynamic-parse-expression* env (map cadr bindings)))) (dynamic-parse-expression* env (map cadr bindings))))
(cons nenv (cons bresults exprs-asg))) (cons nenv (cons bresults exprs-asg)))
(error 'dynamic-parse-parallel-bindings (error "Not a list of bindings: " bindings)))
"Not a list of bindings: ~s" bindings)))
; dynamic-parse-let* ; dynamic-parse-let*
@ -531,7 +532,7 @@
(dynamic-parse-action-let*-expression (dynamic-parse-action-let*-expression
bresults bresults
(dynamic-parse-body (extend-env-with-env env nenv) body))) (dynamic-parse-body (extend-env-with-env env nenv) body)))
(error 'dynamic-parse-let* "Illegal bindings/body: ~s" args))) (error "Illegal bindings/body: " args)))
; dynamic-parse-sequential-bindings ; dynamic-parse-sequential-bindings
@ -565,10 +566,8 @@
(cons bres var-defs) (cons bres var-defs)
(cons new-expr-asg expr-asgs) (cons new-expr-asg expr-asgs)
(cdr binds))) (cdr binds)))
(error 'dynamic-parse-sequential-bindings (error "Illegal binding: " fst-bind))))
"Illegal binding: ~s" fst-bind)))) (else (error "Illegal bindings: " binds))))))
(else (error 'dynamic-parse-sequential-bindings
"Illegal bindings: ~s" binds))))))
(let ((env-vdefs-easgs (psb dynamic-empty-env env '() '() bindings))) (let ((env-vdefs-easgs (psb dynamic-empty-env env '() '() bindings)))
(cons (car env-vdefs-easgs) (cons (car env-vdefs-easgs)
(cons (reverse (cadr env-vdefs-easgs)) (cons (reverse (cadr env-vdefs-easgs))
@ -587,7 +586,7 @@
(dynamic-parse-action-letrec-expression (dynamic-parse-action-letrec-expression
bresults bresults
(dynamic-parse-body (extend-env-with-env env nenv) body))) (dynamic-parse-body (extend-env-with-env env nenv) body)))
(error 'dynamic-parse-letrec "Illegal bindings/body: ~s" args))) (error "Illegal bindings/body: " args)))
; dynamic-parse-recursive-bindings ; dynamic-parse-recursive-bindings
@ -607,7 +606,7 @@
(cons (cons
formals-env formals-env
(cons formals-res exprs-asg))) (cons formals-res exprs-asg)))
(error 'dynamic-parse-recursive-bindings "Illegal bindings: ~s" bindings))) (error "Illegal bindings: " bindings)))
; dynamic-parse-do ; dynamic-parse-do
@ -615,13 +614,13 @@
(define (dynamic-parse-do env args) (define (dynamic-parse-do env args)
;; parses do-expressions ;; parses do-expressions
;; ***Note***: Not implemented! ;; ***Note***: Not implemented!
(error 'dynamic-parse-do "Nothing yet...")) (error "Nothing yet..."))
; dynamic-parse-quasiquote ; dynamic-parse-quasiquote
(define (dynamic-parse-quasiquote env args) (define (dynamic-parse-quasiquote env args)
;; ***Note***: Not implemented! ;; ***Note***: Not implemented!
(error 'dynamic-parse-quasiquote "Nothing yet...")) (error "Nothing yet..."))
;; Command ;; Command
@ -646,7 +645,7 @@
;; parses a sequence of commands ;; parses a sequence of commands
(if (list? commands) (if (list? commands)
(map (lambda (command) (dynamic-parse-command env command)) commands) (map (lambda (command) (dynamic-parse-command env command)) commands)
(error 'dynamic-parse-command* "Invalid sequence of commands: ~s" commands))) (error "Invalid sequence of commands: " commands)))
; dynamic-parse-define ; dynamic-parse-define
@ -664,7 +663,7 @@
(dynamic-parse-action-definition (dynamic-parse-action-definition
(dynamic-parse-variable env pattern) (dynamic-parse-variable env pattern)
(dynamic-parse-expression env (car exp-or-body))) (dynamic-parse-expression env (car exp-or-body)))
(error 'dynamic-parse-define "Not a single expression: ~s" exp-or-body))) (error "Not a single expression: " exp-or-body)))
((pair? pattern) ((pair? pattern)
(let* ((function-name (car pattern)) (let* ((function-name (car pattern))
(function-arg-names (cdr pattern)) (function-arg-names (cdr pattern))
@ -675,8 +674,8 @@
(dynamic-parse-variable env function-name) (dynamic-parse-variable env function-name)
formals-ast formals-ast
(dynamic-parse-body (extend-env-with-env env formals-env) exp-or-body)))) (dynamic-parse-body (extend-env-with-env env formals-env) exp-or-body))))
(else (error 'dynamic-parse-define "Not a valid pattern: ~s" pattern)))) (else (error "Not a valid pattern: " pattern))))
(error 'dynamic-parse-define "Not a valid definition: ~s" args))) (error "Not a valid definition: " args)))
;; Auxiliary routines ;; Auxiliary routines
@ -1094,7 +1093,7 @@
(inst-tvar (tv-func new-tvar)) (inst-tvar (tv-func new-tvar))
(inst-def (tvar-def inst-tvar))) (inst-def (tvar-def inst-tvar)))
(if (null? inst-def) (if (null? inst-def)
(error 'fix "Illegal recursive type: ~s" (error "Illegal recursive type: "
(list (tvar-show new-tvar) '= (tvar-show inst-tvar))) (list (tvar-show new-tvar) '= (tvar-show inst-tvar)))
(begin (begin
(set-def! new-tvar (set-def! new-tvar
@ -1492,8 +1491,8 @@
(map ast-show (cdr syntax-arg))))) (map ast-show (cdr syntax-arg)))))
((23) (cons 'begin ((23) (cons 'begin
(map ast-show syntax-arg))) (map ast-show syntax-arg)))
((24) (error 'ast-show "Do expressions not handled! (~s)" syntax-arg)) ((24) (error "Do expressions not handled! " syntax-arg))
((25) (error 'ast-show "This can't happen: empty encountered!")) ((25) (error "This can't happen: empty encountered!"))
((26) (list 'define ((26) (list 'define
(ast-show (car syntax-arg)) (ast-show (car syntax-arg))
(ast-show (cdr syntax-arg)))) (ast-show (cdr syntax-arg))))
@ -1504,7 +1503,7 @@
(map ast-show (cddr syntax-arg))))) (map ast-show (cddr syntax-arg)))))
((28) (cons 'begin ((28) (cons 'begin
(map ast-show syntax-arg))) (map ast-show syntax-arg)))
(else (error 'ast-show "Unknown abstract syntax operator: ~s" (else (error "Unknown abstract syntax operator: "
syntax-op))))) syntax-op)))))
@ -1523,7 +1522,7 @@
((0 1 2 3 4 5) (ast-arg ast)) ((0 1 2 3 4 5) (ast-arg ast))
((6) (list->vector (map datum-show (ast-arg ast)))) ((6) (list->vector (map datum-show (ast-arg ast))))
((7) (cons (datum-show (car (ast-arg ast))) (datum-show (cdr (ast-arg ast))))) ((7) (cons (datum-show (car (ast-arg ast))) (datum-show (cdr (ast-arg ast)))))
(else (error 'datum-show "This should not happen!")))) (else (error "This should not happen!"))))
; write-to-port ; write-to-port
@ -1634,8 +1633,7 @@
named-var-type) named-var-type)
body-type)) body-type))
((23) (ast-tvar (tail arg))) ((23) (ast-tvar (tail arg)))
((24) (error 'ast-gen ((24) (error "Do-expressions not handled!"))
"Do-expressions not handled! (Argument: ~s) arg"))
((25) (gen-tvar)) ((25) (gen-tvar))
((26) (let ((t-var (ast-tvar (car arg))) ((26) (let ((t-var (ast-tvar (car arg)))
(t-exp (ast-tvar (cdr arg)))) (t-exp (ast-tvar (cdr arg))))
@ -1647,7 +1645,7 @@
(add-constr! (procedure t-formals t-body) t-var) (add-constr! (procedure t-formals t-body) t-var)
t-var)) t-var))
((28) (gen-tvar)) ((28) (gen-tvar))
(else (error 'ast-gen "Can't handle syntax operator: ~s" syntax-op))))) (else (error "Can't handle syntax operator: " syntax-op)))))
(cons syntax-op (cons ntvar arg)))) (cons syntax-op (cons ntvar arg))))
(define ast-con car) (define ast-con car)
@ -1676,7 +1674,7 @@
((null? tvar-list) (null)) ((null? tvar-list) (null))
((pair? tvar-list) (pair (car tvar-list) ((pair? tvar-list) (pair (car tvar-list)
(convert-tvars (cdr tvar-list)))) (convert-tvars (cdr tvar-list))))
(else (error 'convert-tvars "Not a list of tvars: ~s" tvar-list)))) (else (error "Not a list of tvars: " tvar-list))))
;; Pretty-printing abstract syntax trees ;; Pretty-printing abstract syntax trees
@ -1762,8 +1760,8 @@
(map tast-show (cdr syntax-arg))))) (map tast-show (cdr syntax-arg)))))
((23) (cons 'begin ((23) (cons 'begin
(map tast-show syntax-arg))) (map tast-show syntax-arg)))
((24) (error 'tast-show "Do expressions not handled! (~s)" syntax-arg)) ((24) (error "Do expressions not handled! " syntax-arg))
((25) (error 'tast-show "This can't happen: empty encountered!")) ((25) (error "This can't happen: empty encountered!"))
((26) (list 'define ((26) (list 'define
(tast-show (car syntax-arg)) (tast-show (car syntax-arg))
(tast-show (cdr syntax-arg)))) (tast-show (cdr syntax-arg))))
@ -1774,7 +1772,7 @@
(map tast-show (cddr syntax-arg))))) (map tast-show (cddr syntax-arg)))))
((28) (cons 'begin ((28) (cons 'begin
(map tast-show syntax-arg))) (map tast-show syntax-arg)))
(else (error 'tast-show "Unknown abstract syntax operator: ~s" (else (error "Unknown abstract syntax operator: "
syntax-op))) syntax-op)))
syntax-tvar))) syntax-tvar)))
@ -1948,8 +1946,8 @@
(map tag-ast-show (cdr syntax-arg))))) (map tag-ast-show (cdr syntax-arg)))))
((23) (cons 'begin ((23) (cons 'begin
(map tag-ast-show syntax-arg))) (map tag-ast-show syntax-arg)))
((24) (error 'tag-ast-show "Do expressions not handled! (~s)" syntax-arg)) ((24) (error "Do expressions not handled! " syntax-arg))
((25) (error 'tag-ast-show "This can't happen: empty encountered!")) ((25) (error "This can't happen: empty encountered!"))
((26) (list 'define ((26) (list 'define
(tag-ast-show (car syntax-arg)) (tag-ast-show (car syntax-arg))
(tag-ast-show (cdr syntax-arg)))) (tag-ast-show (cdr syntax-arg))))
@ -1962,7 +1960,7 @@
(map tag-ast-show (cddr syntax-arg)))))))) (map tag-ast-show (cddr syntax-arg))))))))
((28) (cons 'begin ((28) (cons 'begin
(map tag-ast-show syntax-arg))) (map tag-ast-show syntax-arg)))
(else (error 'tag-ast-show "Unknown abstract syntax operator: ~s" (else (error "Unknown abstract syntax operator: "
syntax-op))))) syntax-op)))))
@ -2324,8 +2322,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 input1) (s1 input1)
(name "dynamic")) (name "dynamic"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (doit (hide count input1))) (lambda () (doit (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

10
etc/R7RS/src/earley.sch
View File

@ -123,9 +123,9 @@
; Enders of V = (5 19 20) ; Enders of V = (5 19 20)
; Predictors of V = (15 17) ; Predictors of V = (15 17)
(import (rnrs base) (import (scheme base)
(rnrs lists) (scheme read)
(rnrs io simple)) (scheme write))
(define (make-parser grammar lexer) (define (make-parser grammar lexer)
@ -655,8 +655,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "earley")) (name "earley"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (test (hide count (vector->list (make-vector input1 'a))))) (lambda () (test (hide count (vector->list (make-vector input1 'a)))))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

11
etc/R7RS/src/equal.sch
View File

@ -18,10 +18,9 @@
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple) (scheme write))
(rnrs mutable-pairs))
; Returns a list with n elements, all equal to x. ; Returns a list with n elements, all equal to x.
@ -148,7 +147,7 @@
(s1 (number->string input1)) (s1 (number->string input1))
(s0 (number->string input0)) (s0 (number->string input0))
(name "equal")) (name "equal"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s0 ":" s1 ":" s2 ":" s3 ":" s4 ":" s5) (string-append name ":" s0 ":" s1 ":" s2 ":" s3 ":" s4 ":" s5)
1 1
(lambda () (lambda ()
@ -159,3 +158,5 @@
(hide input0 input4) (hide input0 input4)
(hide input0 input5))) (hide input0 input5)))
(lambda (result) (eq? result #t))))) (lambda (result) (eq? result #t)))))
(include "src/common.sch")

45
etc/R7RS/src/fft.sch
View File

@ -1,10 +1,11 @@
;;; FFT - Fast Fourier Transform, translated from "Numerical Recipes in C" ;;; FFT - Fast Fourier Transform, translated from "Numerical Recipes in C"
(import (rnrs base) (import (scheme base)
(rnrs io simple) (scheme inexact)
(rnrs arithmetic flonums)) (scheme write)
(scheme read))
;(define flsin sin) (define div quotient)
(define (four1 data) (define (four1 data)
(let ((n (vector-length data)) (let ((n (vector-length data))
@ -33,12 +34,12 @@
(let loop3 ((mmax 2)) (let loop3 ((mmax 2))
(if (< mmax n) (if (< mmax n)
(let* ((theta (let* ((theta
(fl/ pi*2 (inexact mmax))) (/ pi*2 (inexact mmax)))
(wpr (wpr
(let ((x (flsin (fl* 0.5 theta)))) (let ((x (sin (* 0.5 theta))))
(fl* -2.0 (fl* x x)))) (* -2.0 (* x x))))
(wpi (wpi
(flsin theta))) (sin theta)))
(let loop4 ((wr 1.0) (wi 0.0) (m 0)) (let loop4 ((wr 1.0) (wi 0.0) (m 0))
(if (< m mmax) (if (< m mmax)
(begin (begin
@ -47,24 +48,24 @@
(let* ((j (let* ((j
(+ i mmax)) (+ i mmax))
(tempr (tempr
(fl- (-
(fl* wr (vector-ref data j)) (* wr (vector-ref data j))
(fl* wi (vector-ref data (+ j 1))))) (* wi (vector-ref data (+ j 1)))))
(tempi (tempi
(fl+ (+
(fl* wr (vector-ref data (+ j 1))) (* wr (vector-ref data (+ j 1)))
(fl* wi (vector-ref data j))))) (* wi (vector-ref data j)))))
(vector-set! data j (vector-set! data j
(fl- (vector-ref data i) tempr)) (- (vector-ref data i) tempr))
(vector-set! data (+ j 1) (vector-set! data (+ j 1)
(fl- (vector-ref data (+ i 1)) tempi)) (- (vector-ref data (+ i 1)) tempi))
(vector-set! data i (vector-set! data i
(fl+ (vector-ref data i) tempr)) (+ (vector-ref data i) tempr))
(vector-set! data (+ i 1) (vector-set! data (+ i 1)
(fl+ (vector-ref data (+ i 1)) tempi)) (+ (vector-ref data (+ i 1)) tempi))
(loop5 (+ j mmax)));***)) (loop5 (+ j mmax)));***))
(loop4 (fl+ (fl- (fl* wr wpr) (fl* wi wpi)) wr) (loop4 (+ (- (* wr wpr) (* wi wpi)) wr)
(fl+ (fl+ (fl* wi wpr) (fl* wr wpi)) wi) (+ (+ (* wi wpr) (* wr wpi)) wi)
(+ m 2))))) (+ m 2)))))
));****** ));******
(loop3 (* mmax 2))))))) (loop3 (* mmax 2)))))))
@ -84,9 +85,11 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "fft")) (name "fft"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (lambda ()
(run (hide count (make-vector input1 input2)))) (run (hide count (make-vector input1 input2))))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

8
etc/R7RS/src/fib.sch
View File

@ -1,6 +1,8 @@
;;; FIB -- A classic benchmark, computes fib(n) inefficiently. ;;; FIB -- A classic benchmark, computes fib(n) inefficiently.
(import (rnrs base) (rnrs io simple)) (import (scheme base)
(scheme read)
(scheme write))
(define (fib n) (define (fib n)
(if (< n 2) (if (< n 2)
@ -15,8 +17,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input)) (s1 (number->string input))
(name "fib")) (name "fib"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (fib (hide count input))) (lambda () (fib (hide count input)))
(lambda (result) (= result output))))) (lambda (result) (= result output)))))
(include "src/common.sch")

9
etc/R7RS/src/fibc.sch
View File

@ -1,7 +1,8 @@
;;; FIBC -- FIB using first-class continuations, written by Kent Dybvig ;;; FIBC -- FIB using first-class continuations, written by Kent Dybvig
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define (succ n) (+ n 1)) (define (succ n) (+ n 1))
(define (pred n) (- n 1)) (define (pred n) (- n 1))
@ -31,8 +32,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input)) (s1 (number->string input))
(name "fibc")) (name "fibc"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (fibc (hide count input) (hide count (lambda (n) n)))) (lambda () (fibc (hide count input) (hide count (lambda (n) n))))
(lambda (result) (= result output))))) (lambda (result) (= result output)))))
(include "src/common.sch")

36
etc/R7RS/src/gcbench.sch
View File

@ -32,11 +32,11 @@
; of free memory. There is no portable way to do this in Scheme; each ; of free memory. There is no portable way to do this in Scheme; each
; implementation needs its own version. ; implementation needs its own version.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs records procedural) (scheme write))
(rnrs io simple)
(rnrs arithmetic flonums)) (define div quotient)
(define (run-benchmark2 name thunk) (define (run-benchmark2 name thunk)
(display name) (display name)
@ -48,6 +48,13 @@
(display " Free memory= ???????? bytes") (display " Free memory= ???????? bytes")
(newline)) (newline))
(define-record-type classNode
(make-node-raw left right i j) node?
(left node.left node.left-set!)
(right node.right node.right-set!)
(i node.i)
(j node.j))
(define (gcbench kStretchTreeDepth) (define (gcbench kStretchTreeDepth)
; Nodes used by a tree of a given size ; Nodes used by a tree of a given size
@ -75,21 +82,10 @@
; Elements 3 and 4 of the allocated vectors are useless. ; Elements 3 and 4 of the allocated vectors are useless.
(let* ((classNode (let* ((make-empty-node (lambda () (make-node-raw 0 0 0 0)))
(make-record-type-descriptor
'classNode #f #f #f #f
'#((mutable left) (mutable right) (mutable i) (mutable j))))
(classNode-cd
(make-record-constructor-descriptor classNode #f #f))
(make-node-raw (record-constructor classNode-cd))
(make-empty-node (lambda () (make-node-raw 0 0 0 0)))
(make-node (make-node
(lambda (l r) (lambda (l r)
(make-node-raw l r 0 0))) (make-node-raw l r 0 0))))
(node.left (record-accessor classNode 0))
(node.right (record-accessor classNode 1))
(node.left-set! (record-mutator classNode 0))
(node.right-set! (record-mutator classNode 1)))
; Build tree top down, assigning to older objects. ; Build tree top down, assigning to older objects.
(define (Populate iDepth thisNode) (define (Populate iDepth thisNode)
@ -195,8 +191,10 @@
(newline) (newline)
(display "The use of more or less memory will skew the results.") (display "The use of more or less memory will skew the results.")
(newline) (newline)
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (gcbench (hide count input1))) (lambda () (gcbench (hide count input1)))
(lambda (result) #t)))) (lambda (result) #t))))
(include "src/common.sch")

10
etc/R7RS/src/graphs.sch
View File

@ -1,8 +1,8 @@
;;; GRAPHS -- Obtained from Andrew Wright. ;;; GRAPHS -- Obtained from Andrew Wright.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple)) (scheme write))
;;; ==== util.ss ==== ;;; ==== util.ss ====
@ -606,8 +606,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "graphs")) (name "graphs"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (length (run (hide count input1)))) (lambda () (length (run (hide count input1))))
(lambda (result) (= result output))))) (lambda (result) (= result output)))))
(include "src/common.sch")

11
etc/R7RS/src/lattice.sch
View File

@ -1,9 +1,8 @@
;;; LATTICE -- Obtained from Andrew Wright. ;;; LATTICE -- Obtained from Andrew Wright.
(import (rnrs base) (import (scheme base)
(rnrs lists) (scheme write)
(rnrs io simple) (scheme read))
(rnrs mutable-pairs))
; Given a comparison routine that returns one of ; Given a comparison routine that returns one of
; less ; less
@ -233,8 +232,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "lattice")) (name "lattice"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (run (hide count input1))) (lambda () (run (hide count input1)))
(lambda (result) (= result output))))) (lambda (result) (= result output)))))
(include "src/common.sch")

14
etc/R7RS/src/matrix.sch
View File

@ -1,9 +1,11 @@
;;; MATRIX -- Obtained from Andrew Wright. ;;; MATRIX -- Obtained from Andrew Wright.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple) (scheme write))
(rnrs mutable-pairs))
(define div quotient)
(define mod modulo)
; Chez-Scheme compatibility stuff: ; Chez-Scheme compatibility stuff:
@ -759,8 +761,10 @@
(s2 (number->string input2)) (s2 (number->string input2))
(s1 (number->string input1)) (s1 (number->string input1))
(name "matrix")) (name "matrix"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3) (string-append name ":" s1 ":" s2 ":" s3)
count count
(lambda () (really-go (hide count input1) (hide count input2))) (lambda () (really-go (hide count input1) (hide count input2)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

12
etc/R7RS/src/mazefun.sch
View File

@ -1,9 +1,11 @@
;;; MAZEFUN -- Constructs a maze in a purely functional way, ;;; MAZEFUN -- Constructs a maze in a purely functional way,
;;; written by Marc Feeley. ;;; written by Marc Feeley.
(import (rnrs base) (import (scheme base)
(rnrs lists) (scheme read)
(rnrs io simple)) (scheme write))
(define mod modulo)
(define foldr (define foldr
(lambda (f base lst) (lambda (f base lst)
@ -195,8 +197,10 @@
(s2 (number->string input2)) (s2 (number->string input2))
(s1 (number->string input1)) (s1 (number->string input1))
(name "mazefun")) (name "mazefun"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3) (string-append name ":" s1 ":" s2 ":" s3)
count count
(lambda () (make-maze (hide count input1) (hide count input2))) (lambda () (make-maze (hide count input1) (hide count input2)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

24
etc/R7RS/src/mbrot.sch
View File

@ -1,28 +1,28 @@
;;; MBROT -- Generation of Mandelbrot set fractal. ;;; MBROT -- Generation of Mandelbrot set fractal.
(import (rnrs base) (import (scheme base)
(rnrs io simple) (scheme read)
(rnrs arithmetic flonums)) (scheme write))
(define (count r i step x y) (define (count r i step x y)
(let ((max-count 64) (let ((max-count 64)
(radius^2 16.0)) (radius^2 16.0))
(let ((cr (fl+ r (fl* (inexact x) step))) (let ((cr (+ r (* (inexact x) step)))
(ci (fl+ i (fl* (inexact y) step)))) (ci (+ i (* (inexact y) step))))
(let loop ((zr cr) (let loop ((zr cr)
(zi ci) (zi ci)
(c 0)) (c 0))
(if (= c max-count) (if (= c max-count)
c c
(let ((zr^2 (fl* zr zr)) (let ((zr^2 (* zr zr))
(zi^2 (fl* zi zi))) (zi^2 (* zi zi)))
(if (fl>? (fl+ zr^2 zi^2) radius^2) (if (> (+ zr^2 zi^2) radius^2)
c c
(let ((new-zr (fl+ (fl- zr^2 zi^2) cr)) (let ((new-zr (+ (- zr^2 zi^2) cr))
(new-zi (fl+ (fl* 2.0 (fl* zr zi)) ci))) (new-zi (+ (* 2.0 (* zr zi)) ci)))
(loop new-zr new-zi (+ c 1)))))))))) (loop new-zr new-zi (+ c 1))))))))))
(define (mbrot matrix r i step n) (define (mbrot matrix r i step n)
@ -52,8 +52,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "mbrot")) (name "mbrot"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (test (hide count input1))) (lambda () (test (hide count input1)))
(lambda (result) (= result output))))) (lambda (result) (= result output)))))
(include "src/common.sch")

19
etc/R7RS/src/mbrotZ.sch
View File

@ -1,15 +1,16 @@
;;; MBROT -- Generation of Mandelbrot set fractal ;;; MBROT -- Generation of Mandelbrot set fractal
;;; using Scheme's complex numbers. ;;; using Scheme's complex numbers.
(import (rnrs base) (import (scheme base)
(rnrs io simple) (scheme read)
(rnrs arithmetic flonums)) (scheme write)
(scheme complex))
(define (count z0 step z) (define (count z0 step z)
(let* ((max-count 64) (let* ((max-count 64)
(radius 4.0) (radius 4.0)
(radius^2 (fl* radius radius))) (radius^2 (* radius radius)))
(let ((z0 (+ z0 (* z step)))) (let ((z0 (+ z0 (* z step))))
@ -19,9 +20,9 @@
c c
(let* ((zr (real-part z)) (let* ((zr (real-part z))
(zi (imag-part z)) (zi (imag-part z))
(zr^2 (fl* zr zr)) (zr^2 (* zr zr))
(zi^2 (fl* zi zi))) (zi^2 (* zi zi)))
(if (fl>? (fl+ zr^2 zi^2) radius^2) (if (> (+ zr^2 zi^2) radius^2)
c c
(loop (+ (* z z) z0) (+ c 1))))))))) (loop (+ (* z z) z0) (+ c 1)))))))))
@ -57,8 +58,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "mbrotZ")) (name "mbrotZ"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (test (hide count input1))) (lambda () (test (hide count input1)))
(lambda (result) (= result output))))) (lambda (result) (= result output)))))
(include "src/common.sch")

10
etc/R7RS/src/mperm.sch
View File

@ -13,9 +13,9 @@
; 000820 / wdc Added the MpermNKL benchmark; revised for new run-benchmark. ; 000820 / wdc Added the MpermNKL benchmark; revised for new run-benchmark.
; 071127 / wdc Simplified and ported for R6RS. ; 071127 / wdc Simplified and ported for R6RS.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple)) (scheme write))
; This benchmark is in three parts. Each tests a different aspect of ; This benchmark is in three parts. Each tests a different aspect of
; the memory system. ; the memory system.
@ -193,7 +193,7 @@
(newline)))) (newline))))
(define (run-benchmark . args) (define (run-benchmark . args)
(apply run-r6rs-benchmark args)) (apply run-r7rs-benchmark args))
(define (main) (define (main)
(let* ((input1 (read)) (let* ((input1 (read))
@ -210,3 +210,5 @@
(hide input1 input2) (hide input1 input2)
(hide input1 input3) (hide input1 input3)
(hide input1 input4)))) (hide input1 input4))))
(include "src/common.sch")

12
etc/R7RS/src/nboyer.sch
View File

@ -55,10 +55,10 @@
; The second phase creates the test problem, and tests to see ; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas. ; whether it is implied by the lemmas.
(import (rnrs base) (import (scheme base)
(rnrs lists) (scheme read)
(rnrs control) (scheme write)
(rnrs io simple)) (scheme cxr))
(define (main) (define (main)
(let* ((count (read)) (let* ((count (read))
@ -67,7 +67,7 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input)) (s1 (number->string input))
(name "nboyer")) (name "nboyer"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (lambda ()
@ -773,3 +773,5 @@
(if answer (if answer
rewrite-count rewrite-count
#f))))) #f)))))
(include "src/common.sch")

9
etc/R7RS/src/nqueens.sch
View File

@ -1,7 +1,8 @@
;;; NQUEENS -- Compute number of solutions to 8-queens problem. ;;; NQUEENS -- Compute number of solutions to 8-queens problem.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define trace? #f) (define trace? #f)
@ -37,8 +38,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "nqueens")) (name "nqueens"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (nqueens (hide count input1))) (lambda () (nqueens (hide count input1)))
(lambda (result) (= result output))))) (lambda (result) (= result output)))))
(include "src/common.sch")

9
etc/R7RS/src/ntakl.sch
View File

@ -1,8 +1,9 @@
;;; NTAKL -- The TAKeuchi function using lists as counters, ;;; NTAKL -- The TAKeuchi function using lists as counters,
;;; with an alternative boolean expression. ;;; with an alternative boolean expression.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define (listn n) (define (listn n)
(if (= n 0) (if (= n 0)
@ -51,9 +52,11 @@
(s2 (number->string (length input2))) (s2 (number->string (length input2)))
(s1 (number->string (length input1))) (s1 (number->string (length input1)))
(name "ntakl")) (name "ntakl"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3 ":" s4) (string-append name ":" s1 ":" s2 ":" s3 ":" s4)
count count
(lambda () (lambda ()
(mas (hide count input1) (hide count input2) (hide count input3))) (mas (hide count input1) (hide count input2) (hide count input3)))
(lambda (result) (equal? (length result) output))))) (lambda (result) (equal? (length result) output)))))
(include "src/common.sch")

234
etc/R7RS/src/nucleic.sch
View File

@ -18,9 +18,11 @@
; -- MATH UTILITIES ----------------------------------------------------------- ; -- MATH UTILITIES -----------------------------------------------------------
(import (rnrs base) (import (scheme base)
(rnrs io simple) (scheme read)
(rnrs arithmetic flonums)) (scheme write)
(scheme cxr)
(scheme inexact))
(define-syntax nuc-const (define-syntax nuc-const
(syntax-rules () (syntax-rules ()
@ -32,16 +34,16 @@
(define constant-minus-pi/2 -1.57079632679489661923) (define constant-minus-pi/2 -1.57079632679489661923)
(define (math-atan2 y x) (define (math-atan2 y x)
(cond ((fl>? x 0.0) (cond ((> x 0.0)
(flatan (fl/ y x))) (atan (/ y x)))
((fl<? y 0.0) ((< y 0.0)
(if (fl=? x 0.0) (if (= x 0.0)
constant-minus-pi/2 constant-minus-pi/2
(fl+ (flatan (fl/ y x)) constant-minus-pi))) (+ (atan (/ y x)) constant-minus-pi)))
(else (else
(if (fl=? x 0.0) (if (= x 0.0)
constant-pi/2 constant-pi/2
(fl+ (flatan (fl/ y x)) constant-pi))))) (+ (atan (/ y x)) constant-pi)))))
; -- POINTS ------------------------------------------------------------------- ; -- POINTS -------------------------------------------------------------------
@ -56,22 +58,22 @@
(define (pt-z-set! pt val) (vector-set! pt 2 val)) (define (pt-z-set! pt val) (vector-set! pt 2 val))
(define (pt-sub p1 p2) (define (pt-sub p1 p2)
(make-pt (fl- (pt-x p1) (pt-x p2)) (make-pt (- (pt-x p1) (pt-x p2))
(fl- (pt-y p1) (pt-y p2)) (- (pt-y p1) (pt-y p2))
(fl- (pt-z p1) (pt-z p2)))) (- (pt-z p1) (pt-z p2))))
(define (pt-dist p1 p2) (define (pt-dist p1 p2)
(let ((dx (fl- (pt-x p1) (pt-x p2))) (let ((dx (- (pt-x p1) (pt-x p2)))
(dy (fl- (pt-y p1) (pt-y p2))) (dy (- (pt-y p1) (pt-y p2)))
(dz (fl- (pt-z p1) (pt-z p2)))) (dz (- (pt-z p1) (pt-z p2))))
(flsqrt (fl+ (fl* dx dx) (fl* dy dy) (fl* dz dz))))) (sqrt (+ (* dx dx) (* dy dy) (* dz dz)))))
(define (pt-phi p) (define (pt-phi p)
(let* ((x (pt-x p)) (let* ((x (pt-x p))
(y (pt-y p)) (y (pt-y p))
(z (pt-z p)) (z (pt-z p))
(b (math-atan2 x z))) (b (math-atan2 x z)))
(math-atan2 (fl+ (fl* (flcos b) z) (fl* (flsin b) x)) y))) (math-atan2 (+ (* (cos b) z) (* (sin b) x)) y)))
(define (pt-theta p) (define (pt-theta p)
(math-atan2 (pt-x p) (pt-z p))) (math-atan2 (pt-x p) (pt-z p)))
@ -136,17 +138,17 @@
(y (pt-y p)) (y (pt-y p))
(z (pt-z p))) (z (pt-z p)))
(make-pt (make-pt
(fl+ (fl* x (tfo-a tfo)) (+ (* x (tfo-a tfo))
(fl* y (tfo-d tfo)) (* y (tfo-d tfo))
(fl* z (tfo-g tfo)) (* z (tfo-g tfo))
(tfo-tx tfo)) (tfo-tx tfo))
(fl+ (fl* x (tfo-b tfo)) (+ (* x (tfo-b tfo))
(fl* y (tfo-e tfo)) (* y (tfo-e tfo))
(fl* z (tfo-h tfo)) (* z (tfo-h tfo))
(tfo-ty tfo)) (tfo-ty tfo))
(fl+ (fl* x (tfo-c tfo)) (+ (* x (tfo-c tfo))
(fl* y (tfo-f tfo)) (* y (tfo-f tfo))
(fl* z (tfo-i tfo)) (* z (tfo-i tfo))
(tfo-tz tfo))))) (tfo-tz tfo)))))
; The function "tfo-combine" multiplies two transformation matrices A and B. ; The function "tfo-combine" multiplies two transformation matrices A and B.
@ -155,44 +157,44 @@
(define (tfo-combine A B) (define (tfo-combine A B)
(make-tfo (make-tfo
(fl+ (fl* (tfo-a A) (tfo-a B)) (+ (* (tfo-a A) (tfo-a B))
(fl* (tfo-b A) (tfo-d B)) (* (tfo-b A) (tfo-d B))
(fl* (tfo-c A) (tfo-g B))) (* (tfo-c A) (tfo-g B)))
(fl+ (fl* (tfo-a A) (tfo-b B)) (+ (* (tfo-a A) (tfo-b B))
(fl* (tfo-b A) (tfo-e B)) (* (tfo-b A) (tfo-e B))
(fl* (tfo-c A) (tfo-h B))) (* (tfo-c A) (tfo-h B)))
(fl+ (fl* (tfo-a A) (tfo-c B)) (+ (* (tfo-a A) (tfo-c B))
(fl* (tfo-b A) (tfo-f B)) (* (tfo-b A) (tfo-f B))
(fl* (tfo-c A) (tfo-i B))) (* (tfo-c A) (tfo-i B)))
(fl+ (fl* (tfo-d A) (tfo-a B)) (+ (* (tfo-d A) (tfo-a B))
(fl* (tfo-e A) (tfo-d B)) (* (tfo-e A) (tfo-d B))
(fl* (tfo-f A) (tfo-g B))) (* (tfo-f A) (tfo-g B)))
(fl+ (fl* (tfo-d A) (tfo-b B)) (+ (* (tfo-d A) (tfo-b B))
(fl* (tfo-e A) (tfo-e B)) (* (tfo-e A) (tfo-e B))
(fl* (tfo-f A) (tfo-h B))) (* (tfo-f A) (tfo-h B)))
(fl+ (fl* (tfo-d A) (tfo-c B)) (+ (* (tfo-d A) (tfo-c B))
(fl* (tfo-e A) (tfo-f B)) (* (tfo-e A) (tfo-f B))
(fl* (tfo-f A) (tfo-i B))) (* (tfo-f A) (tfo-i B)))
(fl+ (fl* (tfo-g A) (tfo-a B)) (+ (* (tfo-g A) (tfo-a B))
(fl* (tfo-h A) (tfo-d B)) (* (tfo-h A) (tfo-d B))
(fl* (tfo-i A) (tfo-g B))) (* (tfo-i A) (tfo-g B)))
(fl+ (fl* (tfo-g A) (tfo-b B)) (+ (* (tfo-g A) (tfo-b B))
(fl* (tfo-h A) (tfo-e B)) (* (tfo-h A) (tfo-e B))
(fl* (tfo-i A) (tfo-h B))) (* (tfo-i A) (tfo-h B)))
(fl+ (fl* (tfo-g A) (tfo-c B)) (+ (* (tfo-g A) (tfo-c B))
(fl* (tfo-h A) (tfo-f B)) (* (tfo-h A) (tfo-f B))
(fl* (tfo-i A) (tfo-i B))) (* (tfo-i A) (tfo-i B)))
(fl+ (fl* (tfo-tx A) (tfo-a B)) (+ (* (tfo-tx A) (tfo-a B))
(fl* (tfo-ty A) (tfo-d B)) (* (tfo-ty A) (tfo-d B))
(fl* (tfo-tz A) (tfo-g B)) (* (tfo-tz A) (tfo-g B))
(tfo-tx B)) (tfo-tx B))
(fl+ (fl* (tfo-tx A) (tfo-b B)) (+ (* (tfo-tx A) (tfo-b B))
(fl* (tfo-ty A) (tfo-e B)) (* (tfo-ty A) (tfo-e B))
(fl* (tfo-tz A) (tfo-h B)) (* (tfo-tz A) (tfo-h B))
(tfo-ty B)) (tfo-ty B))
(fl+ (fl* (tfo-tx A) (tfo-c B)) (+ (* (tfo-tx A) (tfo-c B))
(fl* (tfo-ty A) (tfo-f B)) (* (tfo-ty A) (tfo-f B))
(fl* (tfo-tz A) (tfo-i B)) (* (tfo-tz A) (tfo-i B))
(tfo-tz B)))) (tfo-tz B))))
; The function "tfo-inv-ortho" computes the inverse of a homogeneous ; The function "tfo-inv-ortho" computes the inverse of a homogeneous
@ -206,15 +208,15 @@
(tfo-a tfo) (tfo-d tfo) (tfo-g tfo) (tfo-a tfo) (tfo-d tfo) (tfo-g tfo)
(tfo-b tfo) (tfo-e tfo) (tfo-h tfo) (tfo-b tfo) (tfo-e tfo) (tfo-h tfo)
(tfo-c tfo) (tfo-f tfo) (tfo-i tfo) (tfo-c tfo) (tfo-f tfo) (tfo-i tfo)
(fl- (fl+ (fl* (tfo-a tfo) tx) (- (+ (* (tfo-a tfo) tx)
(fl* (tfo-b tfo) ty) (* (tfo-b tfo) ty)
(fl* (tfo-c tfo) tz))) (* (tfo-c tfo) tz)))
(fl- (fl+ (fl* (tfo-d tfo) tx) (- (+ (* (tfo-d tfo) tx)
(fl* (tfo-e tfo) ty) (* (tfo-e tfo) ty)
(fl* (tfo-f tfo) tz))) (* (tfo-f tfo) tz)))
(fl- (fl+ (fl* (tfo-g tfo) tx) (- (+ (* (tfo-g tfo) tx)
(fl* (tfo-h tfo) ty) (* (tfo-h tfo) ty)
(fl* (tfo-i tfo) tz)))))) (* (tfo-i tfo) tz))))))
; Given three points p1, p2, and p3, the function "tfo-align" computes ; Given three points p1, p2, and p3, the function "tfo-align" computes
; a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets ; a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets
@ -223,52 +225,52 @@
(define (tfo-align p1 p2 p3) (define (tfo-align p1 p2 p3)
(let* ((x1 (pt-x p1)) (y1 (pt-y p1)) (z1 (pt-z p1)) (let* ((x1 (pt-x p1)) (y1 (pt-y p1)) (z1 (pt-z p1))
(x3 (pt-x p3)) (y3 (pt-y p3)) (z3 (pt-z p3)) (x3 (pt-x p3)) (y3 (pt-y p3)) (z3 (pt-z p3))
(x31 (fl- x3 x1)) (y31 (fl- y3 y1)) (z31 (fl- z3 z1)) (x31 (- x3 x1)) (y31 (- y3 y1)) (z31 (- z3 z1))
(rotpY (pt-sub p2 p1)) (rotpY (pt-sub p2 p1))
(Phi (pt-phi rotpY)) (Phi (pt-phi rotpY))
(Theta (pt-theta rotpY)) (Theta (pt-theta rotpY))
(sinP (flsin Phi)) (sinP (sin Phi))
(sinT (flsin Theta)) (sinT (sin Theta))
(cosP (flcos Phi)) (cosP (cos Phi))
(cosT (flcos Theta)) (cosT (cos Theta))
(sinPsinT (fl* sinP sinT)) (sinPsinT (* sinP sinT))
(sinPcosT (fl* sinP cosT)) (sinPcosT (* sinP cosT))
(cosPsinT (fl* cosP sinT)) (cosPsinT (* cosP sinT))
(cosPcosT (fl* cosP cosT)) (cosPcosT (* cosP cosT))
(rotpZ (rotpZ
(make-pt (make-pt
(fl- (fl* cosT x31) (- (* cosT x31)
(fl* sinT z31)) (* sinT z31))
(fl+ (fl* sinPsinT x31) (+ (* sinPsinT x31)
(fl* cosP y31) (* cosP y31)
(fl* sinPcosT z31)) (* sinPcosT z31))
(fl+ (fl* cosPsinT x31) (+ (* cosPsinT x31)
(fl- (fl* sinP y31)) (- (* sinP y31))
(fl* cosPcosT z31)))) (* cosPcosT z31))))
(Rho (pt-theta rotpZ)) (Rho (pt-theta rotpZ))
(cosR (flcos Rho)) (cosR (cos Rho))
(sinR (flsin Rho)) (sinR (sin Rho))
(x (fl+ (fl- (fl* x1 cosT)) (x (+ (- (* x1 cosT))
(fl* z1 sinT))) (* z1 sinT)))
(y (fl- (fl- (fl- (fl* x1 sinPsinT)) (y (- (- (- (* x1 sinPsinT))
(fl* y1 cosP)) (* y1 cosP))
(fl* z1 sinPcosT))) (* z1 sinPcosT)))
(z (fl- (fl+ (fl- (fl* x1 cosPsinT)) (z (- (+ (- (* x1 cosPsinT))
(fl* y1 sinP)) (* y1 sinP))
(fl* z1 cosPcosT)))) (* z1 cosPcosT))))
(make-tfo (make-tfo
(fl- (fl* cosT cosR) (fl* cosPsinT sinR)) (- (* cosT cosR) (* cosPsinT sinR))
sinPsinT sinPsinT
(fl+ (fl* cosT sinR) (fl* cosPsinT cosR)) (+ (* cosT sinR) (* cosPsinT cosR))
(fl* sinP sinR) (* sinP sinR)
cosP cosP
(fl- (fl* sinP cosR)) (- (* sinP cosR))
(fl- (fl- (fl* sinT cosR)) (fl* cosPcosT sinR)) (- (- (* sinT cosR)) (* cosPcosT sinR))
sinPcosT sinPcosT
(fl+ (fl- (fl* sinT sinR)) (fl* cosPcosT cosR)) (+ (- (* sinT sinR)) (* cosPcosT cosR))
(fl- (fl* x cosR) (fl* z sinR)) (- (* x cosR) (* z sinR))
y y
(fl+ (fl* x sinR) (fl* z cosR))))) (+ (* x sinR) (* z cosR)))))
; -- NUCLEIC ACID CONFORMATIONS DATA BASE ------------------------------------- ; -- NUCLEIC ACID CONFORMATIONS DATA BASE -------------------------------------
@ -3313,7 +3315,7 @@
(if (= (var-id v) 33) (if (= (var-id v) 33)
(let ((p (atom-pos nuc-P (get-var 34 partial-inst))) ; P in nucleotide 34 (let ((p (atom-pos nuc-P (get-var 34 partial-inst))) ; P in nucleotide 34
(o3* (atom-pos nuc-O3* v))) ; O3' in nucl. 33 (o3* (atom-pos nuc-O3* v))) ; O3' in nucl. 33
(fl<=? (pt-dist p o3*) 3.0)) ; check distance (<= (pt-dist p o3*) 3.0)) ; check distance
#t)) #t))
(define (anticodon) (define (anticodon)
@ -3361,11 +3363,11 @@
((18) ((18)
(let ((p (atom-pos nuc-P (get-var 19 partial-inst))) (let ((p (atom-pos nuc-P (get-var 19 partial-inst)))
(o3* (atom-pos nuc-O3* v))) (o3* (atom-pos nuc-O3* v)))
(fl<=? (pt-dist p o3*) 4.0))) (<= (pt-dist p o3*) 4.0)))
((6) ((6)
(let ((p (atom-pos nuc-P (get-var 7 partial-inst))) (let ((p (atom-pos nuc-P (get-var 7 partial-inst)))
(o3* (atom-pos nuc-O3* v))) (o3* (atom-pos nuc-O3* v)))
(fl<=? (pt-dist p o3*) 4.5))) (<= (pt-dist p o3*) 4.5)))
(else (else
#t))) #t)))
@ -3449,7 +3451,7 @@
(define (distance pos) (define (distance pos)
(let ((abs-pos (tfo-apply (var-tfo v) pos))) (let ((abs-pos (tfo-apply (var-tfo v) pos)))
(let ((x (pt-x abs-pos)) (y (pt-y abs-pos)) (z (pt-z abs-pos))) (let ((x (pt-x abs-pos)) (y (pt-y abs-pos)) (z (pt-z abs-pos)))
(flsqrt (fl+ (fl* x x) (fl* y y) (fl* z z)))))) (sqrt (+ (* x x) (* y y) (* z z))))))
(maximum (map distance (list-of-atoms (var-nuc v))))) (maximum (map distance (list-of-atoms (var-nuc v)))))
@ -3464,7 +3466,7 @@
(if (null? l) (if (null? l)
m m
(let ((x (car l))) (let ((x (car l)))
(loop (if (fl>? x m) x m) (cdr l)))))) (loop (if (> x m) x m) (cdr l))))))
(define (run input) (define (run input)
(most-distant-atom (pseudoknot input))) (most-distant-atom (pseudoknot input)))
@ -3476,11 +3478,13 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 input1) (s1 input1)
(name "nucleic")) (name "nucleic"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (run (hide count input1))) (lambda () (run (hide count input1)))
(lambda (result) (lambda (result)
(and (number? result) (and (number? result)
(let ((x (fl/ result output))) (let ((x (/ result output)))
(and (fl>? x 0.999999) (fl<? x 1.000001)))))))) (and (> x 0.999999) (< x 1.000001))))))))
(include "src/common.sch")

11
etc/R7RS/src/paraffins.sch
View File

@ -1,7 +1,10 @@
;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms. ;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define div quotient)
(define (gen n) (define (gen n)
(let* ((n/2 (div n 2)) (let* ((n/2 (div n 2))
@ -177,8 +180,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "paraffins")) (name "paraffins"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (nb (hide count input1))) (lambda () (nb (hide count input1)))
(lambda (result) (= result output))))) (lambda (result) (= result output)))))
(include "src/common.sch")

15
etc/R7RS/src/parsing.sch
View File

@ -30,12 +30,11 @@
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(import (rnrs base) (import (scheme base)
(rnrs unicode) (scheme read)
(rnrs lists) (scheme write)
(rnrs control) (scheme file)
(rnrs io simple) (scheme char))
(rnrs mutable-strings))
(define (parsing-benchmark . rest) (define (parsing-benchmark . rest)
(let* ((n (if (null? rest) 1000 (car rest))) (let* ((n (if (null? rest) 1000 (car rest)))
@ -935,8 +934,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 input1) (s1 input1)
(name "parsing")) (name "parsing"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
1 1
(lambda () (parsing-benchmark (hide count count) (hide count input1))) (lambda () (parsing-benchmark (hide count count) (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

12
etc/R7RS/src/peval.sch
View File

@ -1,9 +1,9 @@
;;; PEVAL -- A simple partial evaluator for Scheme, written by Marc Feeley. ;;; PEVAL -- A simple partial evaluator for Scheme, written by Marc Feeley.
(import (rnrs base) (import (scheme base)
(rnrs lists) (scheme read)
(rnrs io simple) (scheme write)
(rnrs mutable-pairs)) (scheme cxr))
;------------------------------------------------------------------------------ ;------------------------------------------------------------------------------
@ -636,7 +636,7 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 "") (s1 "")
(name "peval")) (name "peval"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (test (hide count input1) (hide count input2))) (lambda () (test (hide count input1) (hide count input2)))
@ -644,3 +644,5 @@
(and (list? result) (and (list? result)
(= (length result) 10) (= (length result) 10)
(equal? (list-ref result 9) output)))))) (equal? (list-ref result 9) output))))))
(include "src/common.sch")

11
etc/R7RS/src/pi.sch
View File

@ -2,8 +2,11 @@
; See http://mathworld.wolfram.com/Pi.html for the various algorithms. ; See http://mathworld.wolfram.com/Pi.html for the various algorithms.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme write)
(scheme read))
(define div quotient)
; Utilities. ; Utilities.
@ -125,7 +128,7 @@
(s2 (number->string input2)) (s2 (number->string input2))
(s1 (number->string input1)) (s1 (number->string input1))
(name "pi")) (name "pi"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3 ":" s4) (string-append name ":" s1 ":" s2 ":" s3 ":" s4)
count count
(lambda () (lambda ()
@ -133,3 +136,5 @@
(hide count input2) (hide count input2)
(hide count input3))) (hide count input3)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

30
etc/R7RS/src/pnpoly.sch
View File

@ -1,24 +1,24 @@
;;; PNPOLY - Test if a point is contained in a 2D polygon. ;;; PNPOLY - Test if a point is contained in a 2D polygon.
(import (rnrs base) (import (scheme base)
(rnrs io simple) (scheme write)
(rnrs arithmetic flonums)) (scheme read))
(define (pt-in-poly2 xp yp x y) (define (pt-in-poly2 xp yp x y)
(let loop ((c #f) (i (- (vector-length xp) 1)) (j 0)) (let loop ((c #f) (i (- (vector-length xp) 1)) (j 0))
(if (< i 0) (if (< i 0)
c c
(if (or (and (or (fl>? (vector-ref yp i) y) (if (or (and (or (> (vector-ref yp i) y)
(fl>=? y (vector-ref yp j))) (>= y (vector-ref yp j)))
(or (fl>? (vector-ref yp j) y) (or (> (vector-ref yp j) y)
(fl>=? y (vector-ref yp i)))) (>= y (vector-ref yp i))))
(fl>=? x (>= x
(fl+ (vector-ref xp i) (+ (vector-ref xp i)
(fl/ (fl* (/ (*
(fl- (vector-ref xp j) (- (vector-ref xp j)
(vector-ref xp i)) (vector-ref xp i))
(fl- y (vector-ref yp i))) (- y (vector-ref yp i)))
(fl- (vector-ref yp j) (- (vector-ref yp j)
(vector-ref yp i)))))) (vector-ref yp i))))))
(loop c (- i 1) i) (loop c (- i 1) i)
(loop (not c) (- i 1) i))))) (loop (not c) (- i 1) i)))))
@ -49,8 +49,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 "") (s1 "")
(name "pnpoly")) (name "pnpoly"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (run (hide count input1) (hide count input2))) (lambda () (run (hide count input1) (hide count input2)))
(lambda (result) (and (number? result) (= result output)))))) (lambda (result) (and (number? result) (= result output))))))
(include "src/common.sch")

12
etc/R7RS/src/primes.sch
View File

@ -1,7 +1,11 @@
;;; PRIMES -- Compute primes less than 100, written by Eric Mohr. ;;; PRIMES -- Compute primes less than 100, written by Eric Mohr.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define div quotient)
(define mod modulo)
(define (interval-list m n) (define (interval-list m n)
(if (> m n) (if (> m n)
@ -32,8 +36,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "primes")) (name "primes"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (primes<= (hide count input1))) (lambda () (primes<= (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

10
etc/R7RS/src/puzzle.sch
View File

@ -1,8 +1,8 @@
;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal. ;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme write)
(rnrs io simple)) (scheme read))
(define (my-iota n) (define (my-iota n)
(do ((n n (- n 1)) (do ((n n (- n 1))
@ -144,7 +144,7 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 input1) (s1 input1)
(name "puzzle")) (name "puzzle"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (start (hide count input1))) (lambda () (start (hide count input1)))
@ -152,3 +152,5 @@
(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1)))) (for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
(my-iota (+ typemax 1))) (my-iota (+ typemax 1)))
(include "src/common.sch")

39
etc/R7RS/src/quicksort.sch
View File

@ -1,10 +1,9 @@
; This is probably from Lars Hansen's MS thesis. ; This is probably from Lars Hansen's MS thesis.
; The quick-1 benchmark. (Figure 35, page 132.) ; The quick-1 benchmark. (Figure 35, page 132.)
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple) (scheme write))
(rnrs arithmetic flonums))
(define (quick-1 v less?) (define (quick-1 v less?)
@ -92,32 +91,32 @@
(set! random-flonum (set! random-flonum
(lambda () (lambda ()
(let ((seed seed)) ; make it local (let ((seed seed)) ; make it local
(let ((p1 (fl- (fl* a12 (vector-ref seed 1)) (let ((p1 (- (* a12 (vector-ref seed 1))
(fl* a13n (vector-ref seed 0)))) (* a13n (vector-ref seed 0))))
(p2 (fl- (fl* a21 (vector-ref seed 5)) (p2 (- (* a21 (vector-ref seed 5))
(fl* a23n (vector-ref seed 3))))) (* a23n (vector-ref seed 3)))))
(let ((k1 (truncate (fl/ p1 m1))) (let ((k1 (truncate (/ p1 m1)))
(k2 (truncate (fl/ p2 m2))) (k2 (truncate (/ p2 m2)))
(ignore1 (vector-set! seed 0 (vector-ref seed 1))) (ignore1 (vector-set! seed 0 (vector-ref seed 1)))
(ignore3 (vector-set! seed 3 (vector-ref seed 4)))) (ignore3 (vector-set! seed 3 (vector-ref seed 4))))
(let ((p1 (fl- p1 (fl* k1 m1))) (let ((p1 (- p1 (* k1 m1)))
(p2 (fl- p2 (fl* k2 m2))) (p2 (- p2 (* k2 m2)))
(ignore2 (vector-set! seed 1 (vector-ref seed 2))) (ignore2 (vector-set! seed 1 (vector-ref seed 2)))
(ignore4 (vector-set! seed 4 (vector-ref seed 5)))) (ignore4 (vector-set! seed 4 (vector-ref seed 5))))
(let ((p1 (if (fl<? p1 0.0) (fl+ p1 m1) p1)) (let ((p1 (if (< p1 0.0) (+ p1 m1) p1))
(p2 (if (fl<? p2 0.0) (fl+ p2 m2) p2))) (p2 (if (< p2 0.0) (+ p2 m2) p2)))
(vector-set! seed 2 p1) (vector-set! seed 2 p1)
(vector-set! seed 5 p2) (vector-set! seed 5 p2)
(if (fl<=? p1 p2) (if (<= p1 p2)
(fl* norm (fl+ (fl- p1 p2) m1)) (* norm (+ (- p1 p2) m1))
(fl* norm (fl- p1 p2)))))))))) (* norm (- p1 p2))))))))))
(set! seed-ref (lambda () (vector->list seed))) (set! seed-ref (lambda () (vector->list seed)))
(set! seed-set! (lambda l (set! seed (list->vector l))))) (set! seed-set! (lambda l (set! seed (list->vector l)))))
(define (random n) (define (random n)
(exact (fltruncate (fl* (inexact n) (random-flonum))))) (exact (truncate (* (inexact n) (random-flonum)))))
;;; Even with the improved random number generator, ;;; Even with the improved random number generator,
;;; this benchmark still spends almost all of its time ;;; this benchmark still spends almost all of its time
@ -141,7 +140,7 @@
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((= i n)) ((= i n))
(vector-set! v i (random r))) (vector-set! v i (random r)))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s3) (string-append name ":" s1 ":" s3)
count count
(lambda () (quick-1 (vector-map values v) less?)) (lambda () (quick-1 (vector-map values v) less?))
@ -154,3 +153,5 @@
(if (not (<= (vector-ref v (- i 1)) (if (not (<= (vector-ref v (- i 1))
(vector-ref v i))) (vector-ref v i)))
(return #f))))))))) (return #f)))))))))
(include "src/common.sch")

106
etc/R7RS/src/ray.sch
View File

@ -1,11 +1,11 @@
;;; RAY -- Ray-trace a simple scene with spheres, generating a ".pgm" file. ;;; RAY -- Ray-trace a simple scene with spheres, generating a ".pgm" file.
;;; Translated to Scheme from Paul Graham's book ANSI Common Lisp, Example 9.8 ;;; Translated to Scheme from Paul Graham's book ANSI Common Lisp, Example 9.8
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme write)
(rnrs io simple) (scheme read)
(rnrs files) (scheme file)
(rnrs arithmetic flonums)) (scheme inexact))
(define (make-point x y z) (define (make-point x y z)
(vector x y z)) (vector x y z))
@ -14,31 +14,31 @@
(define (point-y p) (vector-ref p 1)) (define (point-y p) (vector-ref p 1))
(define (point-z p) (vector-ref p 2)) (define (point-z p) (vector-ref p 2))
(define (sq x) (fl* x x)) (define (sq x) (* x x))
(define (mag x y z) (define (mag x y z)
(flsqrt (fl+ (sq x) (sq y) (sq z)))) (sqrt (+ (sq x) (sq y) (sq z))))
(define (unit-vector x y z) (define (unit-vector x y z)
(let ((d (mag x y z))) (let ((d (mag x y z)))
(make-point (fl/ x d) (fl/ y d) (fl/ z d)))) (make-point (/ x d) (/ y d) (/ z d))))
(define (distance p1 p2) (define (distance p1 p2)
(mag (fl- (point-x p1) (point-x p2)) (mag (- (point-x p1) (point-x p2))
(fl- (point-y p1) (point-y p2)) (- (point-y p1) (point-y p2))
(fl- (point-z p1) (point-z p2)))) (- (point-z p1) (point-z p2))))
(define (minroot a b c) (define (minroot a b c)
(if (flzero? a) (if (zero? a)
(fl/ (fl- c) b) (/ (- c) b)
(let ((disc (fl- (sq b) (fl* 4.0 a c)))) (let ((disc (- (sq b) (* 4.0 a c))))
(if (flnegative? disc) (if (negative? disc)
#f #f
(let ((discrt (flsqrt disc)) (let ((discrt (sqrt disc))
(minus-b (fl- b)) (minus-b (- b))
(two-a (fl* 2.0 a))) (two-a (* 2.0 a)))
(flmin (fl/ (fl+ minus-b discrt) two-a) (min (/ (+ minus-b discrt) two-a)
(fl/ (fl- minus-b discrt) two-a))))))) (/ (- minus-b discrt) two-a)))))))
(define *world* '()) (define *world* '())
@ -62,18 +62,18 @@
(do ((x 0 (+ x 1))) (do ((x 0 (+ x 1)))
((= x extent)) ((= x extent))
(write (color-at (write (color-at
(fl+ -50.0 (+ -50.0
(fl/ (inexact x) (inexact res))) (/ (inexact x) (inexact res)))
(fl+ -50.0 (+ -50.0
(fl/ (inexact y) (inexact res)))) (/ (inexact y) (inexact res))))
p) p)
(newline p))))))) (newline p)))))))
(define (color-at x y) (define (color-at x y)
(let ((ray (unit-vector (fl- x (point-x eye)) (let ((ray (unit-vector (- x (point-x eye))
(fl- y (point-y eye)) (- y (point-y eye))
(fl- (point-z eye))))) (- (point-z eye)))))
(exact (flround (fl* (sendray eye ray) 255.0))))) (exact (round (* (sendray eye ray) 255.0)))))
@ -82,7 +82,7 @@
(s (vector-ref x 0)) (s (vector-ref x 0))
(int (vector-ref x 1))) (int (vector-ref x 1)))
(if s (if s
(fl* (lambert s int ray) (* (lambert s int ray)
(surface-color s)) (surface-color s))
0.0))) 0.0)))
@ -94,17 +94,17 @@
(let ((h (intersect s pt ray))) (let ((h (intersect s pt ray)))
(if h (if h
(let ((d (distance h pt))) (let ((d (distance h pt)))
(if (fl<? d dist) (if (< d dist)
(loop (cdr lst) s h d) (loop (cdr lst) s h d)
(loop (cdr lst) surface hit dist))) (loop (cdr lst) surface hit dist)))
(loop (cdr lst) surface hit dist))))))) (loop (cdr lst) surface hit dist)))))))
(define (lambert s int ray) (define (lambert s int ray)
(let ((n (normal s int))) (let ((n (normal s int)))
(flmax 0.0 (max 0.0
(fl+ (fl* (point-x ray) (point-x n)) (+ (* (point-x ray) (point-x n))
(fl* (point-y ray) (point-y n)) (* (point-y ray) (point-y n))
(fl* (point-z ray) (point-z n)))))) (* (point-z ray) (point-z n))))))
(define (make-sphere color radius center) (define (make-sphere color radius center)
(vector color radius center)) (vector color radius center))
@ -130,19 +130,19 @@
(zr (point-z ray)) (zr (point-z ray))
(c (sphere-center s)) (c (sphere-center s))
(n (minroot (n (minroot
(fl+ (sq xr) (sq yr) (sq zr)) (+ (sq xr) (sq yr) (sq zr))
(fl* 2.0 (* 2.0
(fl+ (fl* (fl- (point-x pt) (point-x c)) xr) (+ (* (- (point-x pt) (point-x c)) xr)
(fl* (fl- (point-y pt) (point-y c)) yr) (* (- (point-y pt) (point-y c)) yr)
(fl* (fl- (point-z pt) (point-z c)) zr))) (* (- (point-z pt) (point-z c)) zr)))
(fl+ (sq (fl- (point-x pt) (point-x c))) (+ (sq (- (point-x pt) (point-x c)))
(sq (fl- (point-y pt) (point-y c))) (sq (- (point-y pt) (point-y c)))
(sq (fl- (point-z pt) (point-z c))) (sq (- (point-z pt) (point-z c)))
(fl- (sq (sphere-radius s))))))) (- (sq (sphere-radius s)))))))
(if n (if n
(make-point (fl+ (point-x pt) (fl* n xr)) (make-point (+ (point-x pt) (* n xr))
(fl+ (point-y pt) (fl* n yr)) (+ (point-y pt) (* n yr))
(fl+ (point-z pt) (fl* n zr))) (+ (point-z pt) (* n zr)))
#f))) #f)))
(define (normal s pt) (define (normal s pt)
@ -150,9 +150,9 @@
(define (sphere-normal s pt) (define (sphere-normal s pt)
(let ((c (sphere-center s))) (let ((c (sphere-center s)))
(unit-vector (fl- (point-x c) (point-x pt)) (unit-vector (- (point-x c) (point-x pt))
(fl- (point-y c) (point-y pt)) (- (point-y c) (point-y pt))
(fl- (point-z c) (point-z pt))))) (- (point-z c) (point-z pt)))))
(define (ray-test res output-file) (define (ray-test res output-file)
(set! *world* '()) (set! *world* '())
@ -164,9 +164,9 @@
(do ((z 2 (+ z 1))) (do ((z 2 (+ z 1)))
((> z 7)) ((> z 7))
(defsphere (defsphere
(fl* (inexact x) 200.0) (* (inexact x) 200.0)
300.0 300.0
(fl* (inexact z) -400.0) (* (inexact z) -400.0)
40.0 40.0
0.75))) 0.75)))
(tracer output-file res)) (tracer output-file res))
@ -183,8 +183,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "ray")) (name "ray"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (run (hide count input1) (hide count input2))) (lambda () (run (hide count input1) (hide count input2)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

22
etc/R7RS/src/read1.sch
View File

@ -4,10 +4,10 @@
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io ports) (scheme write)
(rnrs io simple)) (scheme file))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
@ -30,9 +30,9 @@
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (read-from-file-benchmark input t) (define (read-from-file-benchmark input)
(call-with-port (call-with-port
(open-file-input-port input (file-options) 'block t) (open-input-file input)
(lambda (in) (lambda (in)
(do ((x (read in) (read in)) (do ((x (read in) (read in))
(y #f x) (y #f x)
@ -44,11 +44,11 @@
(input1 (read)) (input1 (read))
(output (read)) (output (read))
(s2 (number->string count)) (s2 (number->string count))
(s1 input1) (name "read1:latin-1"))
(name "read1:latin-1") (run-r7rs-benchmark
(t (make-transcoder (latin-1-codec))))
(run-r6rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (read-from-file-benchmark (hide count input1) t)) (lambda () (read-from-file-benchmark (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

12
etc/R7RS/src/sboyer.sch
View File

@ -55,10 +55,10 @@
; The second phase creates the test problem, and tests to see ; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas. ; whether it is implied by the lemmas.
(import (rnrs base) (import (scheme base)
(rnrs lists) (scheme read)
(rnrs control) (scheme write)
(rnrs io simple)) (scheme cxr))
(define (main) (define (main)
(let* ((count (read)) (let* ((count (read))
@ -67,7 +67,7 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input)) (s1 (number->string input))
(name "sboyer")) (name "sboyer"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (lambda ()
@ -786,3 +786,5 @@
(if answer (if answer
rewrite-count rewrite-count
#f))))) #f)))))
(include "src/common.sch")

17
etc/R7RS/src/scheme.sch
View File

@ -2,12 +2,13 @@
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(import (rnrs base) (import (scheme base)
(rnrs unicode) (scheme read)
(rnrs lists) (scheme write)
(rnrs io simple) (scheme cxr)
(rnrs mutable-pairs) (scheme inexact)
(rnrs mutable-strings)) (scheme char)
(scheme file))
(define (scheme-eval expr) (define (scheme-eval expr)
(let ((code (scheme-comp expr scheme-global-environment))) (let ((code (scheme-comp expr scheme-global-environment)))
@ -1049,10 +1050,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 "") (s1 "")
(name "scheme")) (name "scheme"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (scheme-eval (hide count input1))) (lambda () (scheme-eval (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (include "src/common.sch")

78
etc/R7RS/src/simplex.sch
View File

@ -1,9 +1,9 @@
;;; SIMPLEX -- Simplex algorithm. ;;; SIMPLEX -- Simplex algorithm.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme write)
(rnrs io simple) (scheme read)
(rnrs arithmetic flonums)) (scheme inexact))
(define (matrix-rows a) (vector-length a)) (define (matrix-rows a) (vector-length a))
(define (matrix-columns a) (vector-length (vector-ref a 0))) (define (matrix-columns a) (vector-length (vector-ref a 0)))
@ -39,11 +39,11 @@
(set! kp (vector-ref l1 0)) (set! kp (vector-ref l1 0))
(set! bmax (matrix-ref a mm kp)) (set! bmax (matrix-ref a mm kp))
(do ((k 1 (+ k 1))) ((>= k nl1)) (do ((k 1 (+ k 1))) ((>= k nl1))
(if (flpositive? (if (positive?
(if abs? (if abs?
(fl- (flabs (matrix-ref a mm (vector-ref l1 k))) (- (abs (matrix-ref a mm (vector-ref l1 k)))
(flabs bmax)) (abs bmax))
(fl- (matrix-ref a mm (vector-ref l1 k)) bmax))) (- (matrix-ref a mm (vector-ref l1 k)) bmax)))
(begin (begin
(set! kp (vector-ref l1 k)) (set! kp (vector-ref l1 k))
(set! bmax (matrix-ref a mm (vector-ref l1 k))))))) (set! bmax (matrix-ref a mm (vector-ref l1 k)))))))
@ -53,59 +53,59 @@
(flag? #f)) (flag? #f))
(do ((i 0 (+ i 1))) ((= i m)) (do ((i 0 (+ i 1))) ((= i m))
(if flag? (if flag?
(if (fl<? (matrix-ref a (vector-ref l2 i) kp) (fl- *epsilon*)) (if (< (matrix-ref a (vector-ref l2 i) kp) (- *epsilon*))
(begin (begin
(let ((q (fl/ (fl- (matrix-ref a (vector-ref l2 i) 0)) (let ((q (/ (- (matrix-ref a (vector-ref l2 i) 0))
(matrix-ref a (vector-ref l2 i) kp)))) (matrix-ref a (vector-ref l2 i) kp))))
(cond (cond
((fl<? q q1) ((< q q1)
(set! ip (vector-ref l2 i)) (set! ip (vector-ref l2 i))
(set! q1 q)) (set! q1 q))
((fl=? q q1) ((= q q1)
(let ((qp 0.0) (let ((qp 0.0)
(q0 0.0)) (q0 0.0))
(let loop ((k 1)) (let loop ((k 1))
(if (<= k n) (if (<= k n)
(begin (begin
(set! qp (set! qp
(fl/ (fl- (matrix-ref a ip k)) (/ (- (matrix-ref a ip k))
(matrix-ref a ip kp))) (matrix-ref a ip kp)))
(set! q0 (set! q0
(fl/ (/
(fl- (-
(matrix-ref a (vector-ref l2 i) k)) (matrix-ref a (vector-ref l2 i) k))
(matrix-ref a (vector-ref l2 i) kp))) (matrix-ref a (vector-ref l2 i) kp)))
(if (fl=? q0 qp) (if (= q0 qp)
(loop (+ k 1)))))) (loop (+ k 1))))))
(if (fl<? q0 qp) (if (< q0 qp)
(set! ip (vector-ref l2 i))))))))) (set! ip (vector-ref l2 i)))))))))
(if (fl<? (matrix-ref a (vector-ref l2 i) kp) (fl- *epsilon*)) (if (< (matrix-ref a (vector-ref l2 i) kp) (- *epsilon*))
(begin (begin
(set! q1 (fl/ (fl- (matrix-ref a (vector-ref l2 i) 0)) (set! q1 (/ (- (matrix-ref a (vector-ref l2 i) 0))
(matrix-ref a (vector-ref l2 i) kp))) (matrix-ref a (vector-ref l2 i) kp)))
(set! ip (vector-ref l2 i)) (set! ip (vector-ref l2 i))
(set! flag? #t))))))) (set! flag? #t)))))))
(define (simp3 one?) (define (simp3 one?)
(let ((piv (fl/ (matrix-ref a ip kp)))) (let ((piv (/ (matrix-ref a ip kp))))
(do ((ii 0 (+ ii 1))) ((= ii (+ m (if one? 2 1)))) (do ((ii 0 (+ ii 1))) ((= ii (+ m (if one? 2 1))))
(if (not (= ii ip)) (if (not (= ii ip))
(begin (begin
(matrix-set! a ii kp (fl* piv (matrix-ref a ii kp))) (matrix-set! a ii kp (* piv (matrix-ref a ii kp)))
(do ((kk 0 (+ kk 1))) ((= kk (+ n 1))) (do ((kk 0 (+ kk 1))) ((= kk (+ n 1)))
(if (not (= kk kp)) (if (not (= kk kp))
(matrix-set! (matrix-set!
a ii kk (fl- (matrix-ref a ii kk) a ii kk (- (matrix-ref a ii kk)
(fl* (matrix-ref a ip kk) (* (matrix-ref a ip kk)
(matrix-ref a ii kp))))))))) (matrix-ref a ii kp)))))))))
(do ((kk 0 (+ kk 1))) ((= kk (+ n 1))) (do ((kk 0 (+ kk 1))) ((= kk (+ n 1)))
(if (not (= kk kp)) (if (not (= kk kp))
(matrix-set! a ip kk (fl* (fl- piv) (matrix-ref a ip kk))))) (matrix-set! a ip kk (* (- piv) (matrix-ref a ip kk)))))
(matrix-set! a ip kp piv))) (matrix-set! a ip kp piv)))
(do ((k 0 (+ k 1))) ((= k n)) (do ((k 0 (+ k 1))) ((= k n))
(vector-set! l1 k (+ k 1)) (vector-set! l1 k (+ k 1))
(vector-set! izrov k k)) (vector-set! izrov k k))
(do ((i 0 (+ i 1))) ((= i m)) (do ((i 0 (+ i 1))) ((= i m))
(if (flnegative? (matrix-ref a (+ i 1) 0)) (if (negative? (matrix-ref a (+ i 1) 0))
(complain)) (complain))
(vector-set! l2 i (+ i 1)) (vector-set! l2 i (+ i 1))
(vector-set! iposv i (+ n i))) (vector-set! iposv i (+ n i)))
@ -113,20 +113,20 @@
(if (positive? (+ m2 m3)) (if (positive? (+ m2 m3))
(begin (begin
(do ((k 0 (+ k 1))) ((= k (+ n 1))) (do ((k 0 (+ k 1))) ((= k (+ n 1)))
(do ((i (+ m1 1) (+ i 1)) (sum 0.0 (fl+ sum (matrix-ref a i k)))) (do ((i (+ m1 1) (+ i 1)) (sum 0.0 (+ sum (matrix-ref a i k))))
((> i m) (matrix-set! a (+ m 1) k (fl- sum))))) ((> i m) (matrix-set! a (+ m 1) k (- sum)))))
(let loop () (let loop ()
(simp1 (+ m 1) #f) (simp1 (+ m 1) #f)
(cond (cond
((fl<=? bmax *epsilon*) ((<= bmax *epsilon*)
(cond ((fl<? (matrix-ref a (+ m 1) 0) (fl- *epsilon*)) (cond ((< (matrix-ref a (+ m 1) 0) (- *epsilon*))
(set! pass2? #f)) (set! pass2? #f))
((fl<=? (matrix-ref a (+ m 1) 0) *epsilon*) ((<= (matrix-ref a (+ m 1) 0) *epsilon*)
(let loop ((ip1 m12)) (let loop ((ip1 m12))
(if (<= ip1 m) (if (<= ip1 m)
(cond ((= (vector-ref iposv (- ip1 1)) (+ ip n -1)) (cond ((= (vector-ref iposv (- ip1 1)) (+ ip n -1))
(simp1 ip1 #t) (simp1 ip1 #t)
(cond ((flpositive? bmax) (cond ((positive? bmax)
(set! ip ip1) (set! ip ip1)
(set! one? #t)) (set! one? #t))
(else (else
@ -137,7 +137,7 @@
(if (vector-ref l3 (- i (+ m1 1))) (if (vector-ref l3 (- i (+ m1 1)))
(do ((k 0 (+ k 1))) ((= k (+ n 1))) (do ((k 0 (+ k 1))) ((= k (+ n 1)))
(matrix-set! (matrix-set!
a i k (fl- (matrix-ref a i k))))))))) a i k (- (matrix-ref a i k)))))))))
(else (else
(simp2) (simp2)
(if (zero? ip) (set! pass2? #f) (set! one? #t))))) (if (zero? ip) (set! pass2? #f) (set! one? #t)))))
@ -157,17 +157,17 @@
(do ((is k (+ is 1))) ((>= is nl1)) (do ((is k (+ is 1))) ((>= is nl1))
(vector-set! l1 is (vector-ref l1 (+ is 1)))) (vector-set! l1 is (vector-ref l1 (+ is 1))))
(matrix-set! (matrix-set!
a (+ m 1) kp (fl+ (matrix-ref a (+ m 1) kp) 1.0)) a (+ m 1) kp (+ (matrix-ref a (+ m 1) kp) 1.0))
(do ((i 0 (+ i 1))) ((= i (+ m 2))) (do ((i 0 (+ i 1))) ((= i (+ m 2)))
(matrix-set! a i kp (fl- (matrix-ref a i kp)))))))) (matrix-set! a i kp (- (matrix-ref a i kp))))))))
((and (>= (vector-ref iposv (- ip 1)) (+ n m1)) ((and (>= (vector-ref iposv (- ip 1)) (+ n m1))
(vector-ref l3 (vector-ref l3
(- (vector-ref iposv (- ip 1)) (+ m1 n)))) (- (vector-ref iposv (- ip 1)) (+ m1 n))))
(vector-set! l3 (- (vector-ref iposv (- ip 1)) (+ m1 n)) #f) (vector-set! l3 (- (vector-ref iposv (- ip 1)) (+ m1 n)) #f)
(matrix-set! (matrix-set!
a (+ m 1) kp (fl+ (matrix-ref a (+ m 1) kp) 1.0)) a (+ m 1) kp (+ (matrix-ref a (+ m 1) kp) 1.0))
(do ((i 0 (+ i 1))) ((= i (+ m 2))) (do ((i 0 (+ i 1))) ((= i (+ m 2)))
(matrix-set! a i kp (fl- (matrix-ref a i kp)))))) (matrix-set! a i kp (- (matrix-ref a i kp))))))
(let ((t (vector-ref izrov (- kp 1)))) (let ((t (vector-ref izrov (- kp 1))))
(vector-set! izrov (- kp 1) (vector-ref iposv (- ip 1))) (vector-set! izrov (- kp 1) (vector-ref iposv (- ip 1)))
(vector-set! iposv (- ip 1) t)) (vector-set! iposv (- ip 1) t))
@ -176,7 +176,7 @@
(let loop () (let loop ()
(simp1 0 #f) (simp1 0 #f)
(cond (cond
((flpositive? bmax) ((positive? bmax)
(simp2) (simp2)
(cond ((zero? ip) #t) (cond ((zero? ip) #t)
(else (simp3 #f) (else (simp3 #f)
@ -203,8 +203,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 "") (s1 "")
(name "simplex")) (name "simplex"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (test (hide count input1))) (lambda () (test (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

18
etc/R7RS/src/slatex.sch
View File

@ -4,14 +4,11 @@
;This file is compatible for the dialect other ;This file is compatible for the dialect other
;(c) Dorai Sitaram, Rice U., 1991, 1994 ;(c) Dorai Sitaram, Rice U., 1991, 1994
(import (import (scheme base)
(rnrs base) (scheme read)
(rnrs unicode) (scheme write)
(rnrs lists) (scheme char)
(rnrs io simple) (scheme file))
(rnrs files)
(rnrs mutable-pairs)
(rnrs mutable-strings))
(define *op-sys* 'unix) (define *op-sys* 'unix)
@ -2353,8 +2350,11 @@
(s2 input2) (s2 input2)
(s1 input1) (s1 input1)
(name "slatex")) (name "slatex"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s3) (string-append name ":" s3)
count count
(lambda () (slatex.process-main-tex-file (hide count input1))) (lambda () (slatex.process-main-tex-file (hide count input1)))
(lambda (result) #t)))) (lambda (result) #t))))
(include "src/common.sch")

12
etc/R7RS/src/string.sch
View File

@ -1,8 +1,10 @@
;;; STRING -- One of the Kernighan and Van Wyk benchmarks. ;;; STRING -- One of the Kernighan and Van Wyk benchmarks.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple)) (scheme write))
(define div quotient)
(define s "abcdef") (define s "abcdef")
@ -31,8 +33,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "string")) (name "string"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (my-try (hide count input1))) (lambda () (my-try (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

9
etc/R7RS/src/sum.sch
View File

@ -1,7 +1,8 @@
;;; SUM -- Compute sum of integers from 0 to 10000 ;;; SUM -- Compute sum of integers from 0 to 10000
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define (run n) (define (run n)
(let loop ((i n) (sum 0)) (let loop ((i n) (sum 0))
@ -16,8 +17,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "sum")) (name "sum"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (run (hide count input1))) (lambda () (run (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

15
etc/R7RS/src/sum1.sch
View File

@ -1,14 +1,16 @@
;;; SUM1 -- One of the Kernighan and Van Wyk benchmarks. ;;; SUM1 -- One of the Kernighan and Van Wyk benchmarks.
(import (rnrs base) (import (scheme base)
(rnrs io simple) (scheme read)
(rnrs arithmetic flonums)) (scheme write)
(scheme file)
(scheme inexact))
(define (sumport port sum-so-far) (define (sumport port sum-so-far)
(let ((x (read port))) (let ((x (read port)))
(if (eof-object? x) (if (eof-object? x)
sum-so-far sum-so-far
(sumport port (fl+ x sum-so-far))))) (sumport port (+ x sum-so-far)))))
(define (sum port) (define (sum port)
(sumport port 0.0)) (sumport port 0.0))
@ -23,9 +25,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 input1) (s1 input1)
(name "sum1")) (name "sum1"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s2) (string-append name ":" s2)
count count
(lambda () (go (hide count input1))) (lambda () (go (hide count input1)))
(lambda (result) (fl<=? (flabs (fl- result output)) 1e-9))))) (lambda (result) (<= (abs (- result output)) 1e-9)))))
(include "src/common.sch")

14
etc/R7RS/src/sumfp.sch
View File

@ -1,14 +1,14 @@
;;; SUMFP -- Compute sum of integers from 0 to 10000 using floating point ;;; SUMFP -- Compute sum of integers from 0 to 10000 using floating point
(import (rnrs base) (import (scheme base)
(rnrs io simple) (scheme read)
(rnrs arithmetic flonums)) (scheme write))
(define (run n) (define (run n)
(let loop ((i n) (sum 0.)) (let loop ((i n) (sum 0.))
(if (fl<? i 0.) (if (< i 0.)
sum sum
(loop (fl- i 1.) (fl+ i sum))))) (loop (- i 1.) (+ i sum)))))
(define (main) (define (main)
(let* ((count (read)) (let* ((count (read))
@ -17,8 +17,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 (number->string input1)) (s1 (number->string input1))
(name "sumfp")) (name "sumfp"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (run (hide count input1))) (lambda () (run (hide count input1)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

16
etc/R7RS/src/tail.sch
View File

@ -7,19 +7,19 @@
;;; is produced, and the lines are then written to the output ;;; is produced, and the lines are then written to the output
;;; in the reverse of the order in which they were read. ;;; in the reverse of the order in which they were read.
(import (rnrs base) (import (scheme base)
(rnrs io ports) (scheme read)
(rnrs io simple) (scheme write)
(rnrs files)) (scheme file))
(define (tail-r-aux port file-so-far) (define (tail-r-aux port file-so-far)
(let ((x (get-line port))) (let ((x (read-line port)))
(if (eof-object? x) (if (eof-object? x)
file-so-far file-so-far
(tail-r-aux port (cons x file-so-far))))) (tail-r-aux port (cons x file-so-far)))))
(define (echo-lines-in-reverse-order in out) (define (echo-lines-in-reverse-order in out)
(for-each (lambda (line) (put-string out line) (newline out)) (for-each (lambda (line) (write-string line out) (newline out))
(tail-r-aux in '()))) (tail-r-aux in '())))
(define (go input output) (define (go input output)
@ -41,8 +41,10 @@
(s2 input2) (s2 input2)
(s1 input1) (s1 input1)
(name "tail")) (name "tail"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s3) (string-append name ":" s3)
count count
(lambda () (go (hide count input1) (hide count input2))) (lambda () (go (hide count input1) (hide count input2)))
(lambda (result) #t)))) (lambda (result) #t))))
(include "src/common.sch")

9
etc/R7RS/src/tak.sch
View File

@ -1,7 +1,8 @@
;;; TAK -- A vanilla version of the TAKeuchi function. ;;; TAK -- A vanilla version of the TAKeuchi function.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define (tak x y z) (define (tak x y z)
(if (not (< y x)) (if (not (< y x))
@ -21,9 +22,11 @@
(s2 (number->string input2)) (s2 (number->string input2))
(s1 (number->string input1)) (s1 (number->string input1))
(name "tak")) (name "tak"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3 ":" s4) (string-append name ":" s1 ":" s2 ":" s3 ":" s4)
count count
(lambda () (lambda ()
(tak (hide count input1) (hide count input2) (hide count input3))) (tak (hide count input1) (hide count input2) (hide count input3)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

9
etc/R7RS/src/takl.sch
View File

@ -1,7 +1,8 @@
;;; TAKL -- The TAKeuchi function using lists as counters. ;;; TAKL -- The TAKeuchi function using lists as counters.
(import (rnrs base) (import (scheme base)
(rnrs io simple)) (scheme read)
(scheme write))
(define (listn n) (define (listn n)
(if (= n 0) (if (= n 0)
@ -36,9 +37,11 @@
(s2 (number->string (length input2))) (s2 (number->string (length input2)))
(s1 (number->string (length input1))) (s1 (number->string (length input1)))
(name "takl")) (name "takl"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3 ":" s4) (string-append name ":" s1 ":" s2 ":" s3 ":" s4)
count count
(lambda () (lambda ()
(mas (hide count input1) (hide count input2) (hide count input3))) (mas (hide count input1) (hide count input2) (hide count input3)))
(lambda (result) (equal? (length result) output))))) (lambda (result) (equal? (length result) output)))))
(include "src/common.sch")

10
etc/R7RS/src/triangl.sch
View File

@ -1,8 +1,8 @@
;;; TRIANGL -- Board game benchmark. ;;; TRIANGL -- Board game benchmark.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple)) (scheme write))
(define *board* (define *board*
(list->vector '(1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1))) (list->vector '(1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1)))
@ -63,8 +63,10 @@
(s2 (number->string input2)) (s2 (number->string input2))
(s1 (number->string input1)) (s1 (number->string input1))
(name "triangl")) (name "triangl"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3) (string-append name ":" s1 ":" s2 ":" s3)
count count
(lambda () (test (hide count input1) (hide count input2))) (lambda () (test (hide count input1) (hide count input2)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")

12
etc/R7RS/src/wc.sch
View File

@ -1,9 +1,11 @@
;;; WC -- One of the Kernighan and Van Wyk benchmarks. ;;; WC -- One of the Kernighan and Van Wyk benchmarks.
;;; Rewritten by Will Clinger into more idiomatic (and correct!) Scheme. ;;; Rewritten by Will Clinger into more idiomatic (and correct!) Scheme.
(import (rnrs base) (import (scheme base)
(rnrs control) (scheme read)
(rnrs io simple)) (scheme write)
(scheme file)
(scheme char))
(define (wcport port) (define (wcport port)
(define (loop nl nw nc inword?) (define (loop nl nw nc inword?)
@ -28,8 +30,10 @@
(s2 (number->string count)) (s2 (number->string count))
(s1 input) (s1 input)
(name "wc")) (name "wc"))
(run-r6rs-benchmark (run-r7rs-benchmark
(string-append name ":" s1 ":" s2) (string-append name ":" s1 ":" s2)
count count
(lambda () (go (hide count input))) (lambda () (go (hide count input)))
(lambda (result) (equal? result output))))) (lambda (result) (equal? result output)))))
(include "src/common.sch")