apply R6RS -> R7RS patch supplied by @SaitoAtsushi.
This commit is contained in:
Sunrin SHIMURA (keen)
parent
cd94f5b554
commit
5ba9154265
207
etc/R7RS/bench
207
etc/R7RS/bench
|
|
@ -1,4 +1,4 @@
|
|||
#! /usr/bin/env bash
|
||||
#!/usr/bin/env bash
|
||||
|
||||
# For running R6RS benchmarks.
|
||||
#
|
||||
|
|
@ -34,23 +34,23 @@ HOME="`( pwd )`"
|
|||
SRC="${HOME}/src"
|
||||
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"
|
||||
|
||||
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"
|
||||
|
||||
|
|
@ -91,13 +91,11 @@ setup ()
|
|||
|
||||
# For both Solaris and Linux machines.
|
||||
|
||||
LARCENY=${LARCENY:-"../../../larceny"}
|
||||
PETIT=${PETIT:-"../../../petit-larceny"}
|
||||
PLTR6RS=${PLTR6RS:-"plt-r6rs"}
|
||||
YPSILON=${YPSILON:-"ypsilon"}
|
||||
MOSH=${MOSH:-"mosh"}
|
||||
PETITE=${PETITE:-"petite"}
|
||||
|
||||
SAGITTARIUS=${SAGITTARIUS:-"sash"}
|
||||
GAUCHE=${GAUCHE:-"gosh"}
|
||||
FOMENT=${FOMENT:-"foment"}
|
||||
HUSK=${HUSK:-"huski"}
|
||||
CHIBI=${CHIBI:-"chibi-scheme"}
|
||||
}
|
||||
|
||||
setup
|
||||
|
|
@ -112,13 +110,8 @@ Usage: bench [-r runs] <system> <benchmark>
|
|||
|
||||
<system> is the abbreviated name of the implementation to benchmark:
|
||||
|
||||
ikarus for Ikarus
|
||||
larceny for Larceny
|
||||
mosh for Mosh
|
||||
petit for Petit Larceny
|
||||
petite for Petite Chez
|
||||
plt for PLT Scheme
|
||||
ypsilon for Ypsilon
|
||||
sagittarius for Sagittarius Scheme
|
||||
gauche for Gauche Scheme
|
||||
all for all of the above
|
||||
|
||||
<benchmark> is the name of the benchmark(s) to run:
|
||||
|
|
@ -161,128 +154,82 @@ evaluate ()
|
|||
{
|
||||
echo
|
||||
echo Testing $1 under ${NAME}
|
||||
make_src_code $1
|
||||
echo Compiling...
|
||||
$COMP "${TEMP}/$1.${EXTENSION}"
|
||||
# $COMP "${TEMP}/$1.${EXTENSION}"
|
||||
i=0
|
||||
while [ "$i" -lt "$NB_RUNS" ]
|
||||
do
|
||||
echo Running...
|
||||
$EXEC "${TEMP}/$1.${EXTENSIONCOMP}" "${INPUTS}/$1.input"
|
||||
$EXEC "${SRC}/$1.sch" "${INPUTS}/$1.input"
|
||||
i=`expr $i + 1`
|
||||
done
|
||||
} 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
|
||||
#
|
||||
# The --nocontract command-line option reduces variability
|
||||
# of timing, and probably corresponds to the default for
|
||||
# most other systems.
|
||||
# Definitions specific to Sagittarius Scheme
|
||||
|
||||
larceny_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 ()
|
||||
sagittarius_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 ()
|
||||
{
|
||||
echo | time "${PLTR6RS}" --compile "$1"
|
||||
}
|
||||
|
||||
plt_exec ()
|
||||
{
|
||||
time "${PLTR6RS}" "$1" < "$2"
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# Definitions specific to Ypsilon
|
||||
|
||||
ypsilon_comp ()
|
||||
gauche_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
|
||||
|
||||
larceny) NAME='Larceny'
|
||||
COMP=larceny_comp
|
||||
EXEC=larceny_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
|
||||
sagittarius)NAME='Sagittarius'
|
||||
COMP=sagittarius_comp
|
||||
EXEC=sagittarius_exec
|
||||
COMPOPTS=""
|
||||
EXTENSION="sch"
|
||||
EXTENSIONCOMP="sch"
|
||||
|
|
@ -369,9 +286,9 @@ for system in $systems ; do
|
|||
EXECCOMMANDS=""
|
||||
;;
|
||||
|
||||
plt) NAME='PLT'
|
||||
COMP=plt_comp
|
||||
EXEC=plt_exec
|
||||
gauche)NAME='Gauche'
|
||||
COMP=gauche_comp
|
||||
EXEC=gauche_exec
|
||||
COMPOPTS=""
|
||||
EXTENSION="sch"
|
||||
EXTENSIONCOMP="sch"
|
||||
|
|
@ -379,9 +296,9 @@ for system in $systems ; do
|
|||
EXECCOMMANDS=""
|
||||
;;
|
||||
|
||||
ypsilon) NAME='Ypsilon' # copied from Ikarus' settings...
|
||||
COMP=ypsilon_comp
|
||||
EXEC=ypsilon_exec
|
||||
chibi)NAME='Chibi'
|
||||
COMP=chibi_comp
|
||||
EXEC=chibi_exec
|
||||
COMPOPTS=""
|
||||
EXTENSION="sch"
|
||||
EXTENSIONCOMP="sch"
|
||||
|
|
@ -389,9 +306,9 @@ for system in $systems ; do
|
|||
EXECCOMMANDS=""
|
||||
;;
|
||||
|
||||
mosh) NAME='Mosh'
|
||||
COMP=mosh_comp
|
||||
EXEC=mosh_exec
|
||||
foment)NAME='Foment'
|
||||
COMP=foment_comp
|
||||
EXEC=foment_exec
|
||||
COMPOPTS=""
|
||||
EXTENSION="sch"
|
||||
EXTENSIONCOMP="sch"
|
||||
|
|
@ -399,9 +316,9 @@ for system in $systems ; do
|
|||
EXECCOMMANDS=""
|
||||
;;
|
||||
|
||||
petite) NAME='Petite'
|
||||
COMP=petite_comp
|
||||
EXEC=petite_exec
|
||||
husk)NAME='Husk'
|
||||
COMP=husk_comp
|
||||
EXEC=husk_exec
|
||||
COMPOPTS=""
|
||||
EXTENSION="sch"
|
||||
EXTENSIONCOMP="sch"
|
||||
|
|
@ -417,7 +334,7 @@ for system in $systems ; do
|
|||
echo Benchmarking ${NAME} on `date` under `uname -a`
|
||||
} >> results.${NAME}
|
||||
|
||||
mkdir "${TEMP}"
|
||||
# mkdir "${TEMP}"
|
||||
|
||||
for program in $benchmarks ; do
|
||||
evaluate $program
|
||||
|
|
|
|||
|
|
@ -3,16 +3,18 @@
|
|||
(*a *b *b *a (*a) (*b))
|
||||
(? ? * (b a) * ? ?))
|
||||
|
||||
(\x38;37 \x31;77 \x31;090 \x36;17 \x36;61 \x37;49 \x36;28 \x35;6
|
||||
\x38;26 \x34;08 \x31;035 \x34;74 \x33;20 \x34;52 \x36;72 \x39;91
|
||||
\x31;55 \x31;22 \x37;93 \x32;21 \x37;16 \x37;27 \x38;48 \x33;09
|
||||
\x31;44 \x39;36 \x31;00 \x38;81 \x32;87 \x34;30 \x32;3 \x37;71
|
||||
\x32;32 \x38;04 \x39;58 \x36;50 \x31;068 \x31;057 \x34;63 \x32;76
|
||||
\x31;046 \x31;002 \x31;99 \x33;4 \x37;38 \x32;10 \x35;40 \x33;97
|
||||
\x33;42 \x33;64 \x37;82 \x36;83 \x38;9 \x33;75 \x31;66 \x35;95
|
||||
\x38;92 \x37;05 \x35;07 \x36;39 \x33;31 \x31;88 \x32;43 \x34;41
|
||||
\x31;013 \x31;079 \x36;7 \x32;98 \x33;86 \x35;73 \x38;59 \x31;33
|
||||
\x37;60 \x31;2 \x35;29 \x38;15 \x31;11 \x34;96 \x34;5 \x32;65
|
||||
\x39;25 \x39;03 \x32;54 \x37;8 \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)
|
||||
(|\x38;37| |\x31;77| |\x31;090| |\x36;17| |\x36;61| |\x37;49| |\x36;28|
|
||||
|\x35;6| |\x38;26| |\x34;08| |\x31;035| |\x34;74| |\x33;20| |\x34;52|
|
||||
|\x36;72| |\x39;91| |\x31;55| |\x31;22| |\x37;93| |\x32;21| |\x37;16|
|
||||
|\x37;27| |\x38;48| |\x33;09| |\x31;44| |\x39;36| |\x31;00| |\x38;81|
|
||||
|\x32;87| |\x34;30| |\x32;3| |\x37;71| |\x32;32| |\x38;04| |\x39;58|
|
||||
|\x36;50| |\x31;068| |\x31;057| |\x34;63| |\x32;76| |\x31;046| |\x31;002|
|
||||
|\x31;99| |\x33;4| |\x37;38| |\x32;10| |\x35;40| |\x33;97| |\x33;42|
|
||||
|\x33;64| |\x37;82| |\x36;83| |\x38;9| |\x33;75| |\x31;66| |\x35;95|
|
||||
|\x38;92| |\x37;05| |\x35;07| |\x36;39| |\x33;31| |\x31;88| |\x32;43|
|
||||
|\x34;41| |\x31;013| |\x31;079| |\x36;7| |\x32;98| |\x33;86| |\x35;73|
|
||||
|\x38;59| |\x31;33| |\x37;60| |\x31;2| |\x35;29| |\x38;15| |\x31;11|
|
||||
|\x34;96| |\x34;5| |\x32;65| |\x39;25| |\x39;03| |\x32;54| |\x37;8|
|
||||
|\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|)
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@
|
|||
(define (binding-show binding)
|
||||
; returns a printable representation of a type binding
|
||||
(cons (key-show (binding-key binding))
|
||||
(cons ': (value-show (binding-value binding)))))
|
||||
(cons '|:| (value-show (binding-value binding)))))
|
||||
|
||||
|
||||
; environments
|
||||
|
|
@ -2281,7 +2281,7 @@
|
|||
; displays the top level environment
|
||||
(map (lambda (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)))
|
||||
; ----------------------------------------------------------------------------
|
||||
; Dynamic type inference for Scheme
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
;;; ACK -- One of the Kernighan and Van Wyk benchmarks.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (ack m n)
|
||||
(cond ((= m 0) (+ n 1))
|
||||
|
|
@ -16,8 +17,10 @@
|
|||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "ack"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (ack (hide count input1) (hide count input2)))
|
||||
(lambda (result) (= result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
;;; ARRAY1 -- One of the Kernighan and Van Wyk benchmarks.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme read))
|
||||
|
||||
(define (create-x n)
|
||||
(define result (make-vector n))
|
||||
|
|
@ -34,8 +34,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "array1"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
1
|
||||
(lambda () (go (hide count count) (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
;;; BROWSE -- Benchmark to create and browse through
|
||||
;;; an AI-like data base of units.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs control)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define mod modulo)
|
||||
|
||||
(define (lookup key table)
|
||||
(let loop ((x table))
|
||||
|
|
@ -200,8 +200,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 "")
|
||||
(name "browse"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (browse (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
;;; CAT -- One of the Kernighan and Van Wyk benchmarks.
|
||||
;;; Rewritten by Will Clinger into more idiomatic Scheme.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple)
|
||||
(rnrs files))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme file)
|
||||
(scheme write))
|
||||
|
||||
(define (catport in out)
|
||||
(let ((x (read-char in)))
|
||||
|
|
@ -32,8 +33,10 @@
|
|||
(s2 input2)
|
||||
(s1 input1)
|
||||
(name "cat"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s3)
|
||||
count
|
||||
(lambda () (go (hide count input1) (hide count input2)))
|
||||
(lambda (result) #t))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@
|
|||
;;; provide timings for the benchmark proper (without startup
|
||||
;;; and compile time).
|
||||
|
||||
(define (run-r6rs-benchmark name count thunk ok?)
|
||||
(define (run-r7rs-benchmark name count thunk ok?)
|
||||
(display "Running ")
|
||||
(display name)
|
||||
(newline)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,19 @@
|
|||
;(define integer->char ascii->char)
|
||||
;(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 (pp-expression expr port) (write expr port) (newline port))
|
||||
(define (write-returning-len obj port) (write obj port) 1)
|
||||
|
|
@ -841,7 +852,7 @@
|
|||
(loop (cdr l))))
|
||||
(declaration-value name element default (env-parent-ref decls))))))
|
||||
(define namespace-sym
|
||||
(let ([s (string->canonical-symbol "NAMESPACE")])
|
||||
(let ((s (string->canonical-symbol "NAMESPACE")))
|
||||
(define-namable-string-decl s)
|
||||
s))
|
||||
(define (node-parent x) (vector-ref x 1))
|
||||
|
|
@ -11144,10 +11155,12 @@
|
|||
(output (read))
|
||||
(s (number->string count))
|
||||
(name "compiler"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s)
|
||||
count
|
||||
(lambda ()
|
||||
(ce (hide count input1) (hide count input2) (hide count input3))
|
||||
(asm-output-get))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,10 +1,8 @@
|
|||
;;; CONFORM -- Type checker, written by Jim Miller.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs unicode)
|
||||
(rnrs lists)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
;;; Functional and unstable
|
||||
|
||||
|
|
@ -462,8 +460,10 @@
|
|||
(output (read))
|
||||
(s (number->string count))
|
||||
(name "conform"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s)
|
||||
count
|
||||
(lambda () (apply test input1))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
;;; CPSTAK -- A continuation-passing version of the TAK benchmark.
|
||||
;;; A good test of first class procedures and tail recursion.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (cpstak x y z)
|
||||
|
||||
|
|
@ -36,9 +37,11 @@
|
|||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "cpstak"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3 ":" s4)
|
||||
count
|
||||
(lambda ()
|
||||
(cpstak (hide count input1) (hide count input2) (hide count input3)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
;;; CTAK -- A version of the TAK procedure that uses continuations.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (ctak x y z)
|
||||
(call-with-current-continuation
|
||||
|
|
@ -32,9 +33,11 @@
|
|||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "ctak"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3 ":" s4)
|
||||
count
|
||||
(lambda ()
|
||||
(ctak (hide count input1) (hide count input2) (hide count input3)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
;;; DERIV -- Symbolic derivation.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme cxr))
|
||||
|
||||
;;; Returns the wrong answer for quotients.
|
||||
;;; Fortunately these aren't used in the benchmark.
|
||||
|
|
@ -40,8 +42,10 @@
|
|||
(output (read))
|
||||
(s (number->string count))
|
||||
(name "deriv"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s)
|
||||
count
|
||||
(lambda () (deriv (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
;;; DESTRUC -- Destructive operation benchmark.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define div quotient)
|
||||
|
||||
(define (append-to-tail! x y)
|
||||
(if (null? x)
|
||||
|
|
@ -55,9 +56,11 @@
|
|||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "destruc"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3)
|
||||
count
|
||||
(lambda ()
|
||||
(destructive (hide count input1) (hide count input2)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
;;; DIVITER -- Benchmark which divides by 2 using lists of n ()'s.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (create-n n)
|
||||
(do ((n n (- n 1))
|
||||
|
|
@ -22,9 +22,11 @@
|
|||
(s1 (number->string input1))
|
||||
(ll (create-n (hide count input1)))
|
||||
(name "diviter"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda ()
|
||||
(iterative-div2 ll))
|
||||
(lambda (result) (equal? (length result) output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
;;; DIVREC -- Benchmark which divides by 2 using lists of n ()'s.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (create-n n)
|
||||
(do ((n n (- n 1))
|
||||
|
|
@ -21,9 +21,11 @@
|
|||
(s1 (number->string input1))
|
||||
(ll (create-n (hide count input1)))
|
||||
(name "divrec"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda ()
|
||||
(recursive-div2 ll))
|
||||
(lambda (result) (equal? (length result) output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
(import (rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs))
|
||||
|
||||
(import (scheme base)
|
||||
(scheme file)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme cxr))
|
||||
|
||||
;;; DYNAMIC -- Obtained from Andrew Wright.
|
||||
|
||||
|
|
@ -131,7 +133,7 @@
|
|||
((pair? e)
|
||||
(dynamic-parse-action-pair-const (dynamic-parse-datum (car e))
|
||||
(dynamic-parse-datum (cdr e))))
|
||||
(else (error 'dynamic-parse-datum "Unknown datum: ~s" e))))
|
||||
(else (error "Unknown datum: " e))))
|
||||
|
||||
|
||||
; VarDef
|
||||
|
|
@ -145,13 +147,13 @@
|
|||
(if (symbol? e)
|
||||
(cond
|
||||
((memq e syntactic-keywords)
|
||||
(error 'dynamic-parse-formal "Illegal identifier (keyword): ~s" e))
|
||||
(error "Illegal identifier (keyword): " e))
|
||||
((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)))
|
||||
(cons (gen-binding e 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*
|
||||
|
||||
|
|
@ -177,7 +179,7 @@
|
|||
(extend-env-with-binding f-env binding)
|
||||
(cons var-result results)
|
||||
(cdr formals))))
|
||||
(else (error 'dynamic-parse-formal* "Illegal formals: ~s" formals))))))
|
||||
(else (error "Illegal formals: " formals))))))
|
||||
(let ((renv-rres (pf* dynamic-empty-env '() formals)))
|
||||
(cons (car renv-rres) (reverse (cdr renv-rres))))))
|
||||
|
||||
|
|
@ -251,7 +253,7 @@
|
|||
(cond
|
||||
((null? es) results)
|
||||
((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))))
|
||||
|
||||
|
||||
|
|
@ -266,7 +268,7 @@
|
|||
(fst-res (dynamic-parse-expression env fst-expr))
|
||||
(rem-res (dynamic-parse-expressions env rem-exprs)))
|
||||
(dynamic-parse-action-pair-arg fst-res rem-res)))
|
||||
(else (error 'dynamic-parse-expressions "Illegal expression list: ~s"
|
||||
(else (error "Illegal expression list: "
|
||||
exprs))))
|
||||
|
||||
|
||||
|
|
@ -275,12 +277,12 @@
|
|||
(define (dynamic-parse-variable env e)
|
||||
(if (symbol? e)
|
||||
(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)))
|
||||
(if assoc-var-def
|
||||
(dynamic-parse-action-variable (binding-value assoc-var-def))
|
||||
(dynamic-parse-action-identifier e))))
|
||||
(error 'dynamic-parse-variable "Not an identifier: ~s" e)))
|
||||
(error "Not an identifier: " e)))
|
||||
|
||||
|
||||
; dynamic-parse-procedure-call
|
||||
|
|
@ -296,7 +298,7 @@
|
|||
(define (dynamic-parse-quote env args)
|
||||
(if (list-of-1? 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
|
||||
|
|
@ -311,7 +313,7 @@
|
|||
(dynamic-parse-action-lambda-expression
|
||||
fresults
|
||||
(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
|
||||
|
|
@ -353,7 +355,7 @@
|
|||
#f))
|
||||
(if (pair? body)
|
||||
(dynamic-parse-command* (def-var* env body) body)
|
||||
(error 'dynamic-parse-body "Illegal body: ~s" body)))
|
||||
(error "Illegal body: " body)))
|
||||
|
||||
; dynamic-parse-if
|
||||
|
||||
|
|
@ -369,7 +371,7 @@
|
|||
(dynamic-parse-expression env (car args))
|
||||
(dynamic-parse-expression env (cadr args))
|
||||
(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
|
||||
|
|
@ -379,7 +381,7 @@
|
|||
(dynamic-parse-action-assignment
|
||||
(dynamic-parse-variable env (car 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
|
||||
|
|
@ -397,7 +399,7 @@
|
|||
(map (lambda (e)
|
||||
(dynamic-parse-cond-clause env e))
|
||||
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
|
||||
|
||||
|
|
@ -409,7 +411,7 @@
|
|||
(dynamic-parse-action-empty)
|
||||
(dynamic-parse-expression env (car 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
|
||||
|
|
@ -418,7 +420,7 @@
|
|||
(if (list? args)
|
||||
(dynamic-parse-action-and-expression
|
||||
(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
|
||||
|
|
@ -427,7 +429,7 @@
|
|||
(if (list? args)
|
||||
(dynamic-parse-action-or-expression
|
||||
(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
|
||||
|
|
@ -439,7 +441,7 @@
|
|||
(map (lambda (e)
|
||||
(dynamic-parse-case-clause env e))
|
||||
(cdr args)))
|
||||
(error 'dynamic-parse-case "Not a list of clauses: ~s" args)))
|
||||
(error "Not a list of clauses: " args)))
|
||||
|
||||
; dynamic-parse-case-clause
|
||||
|
||||
|
|
@ -451,9 +453,9 @@
|
|||
(list (dynamic-parse-action-empty)))
|
||||
((list? (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)))
|
||||
(error 'dynamic-parse-case-clause "Not case clause: ~s" e)))
|
||||
(error "Not case clause: " e)))
|
||||
|
||||
|
||||
; dynamic-parse-let
|
||||
|
|
@ -463,7 +465,7 @@
|
|||
(if (symbol? (car args))
|
||||
(dynamic-parse-named-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
|
||||
|
|
@ -498,7 +500,7 @@
|
|||
(dynamic-parse-body (extend-env-with-env
|
||||
(extend-env-with-binding env vbind)
|
||||
nenv) body)))
|
||||
(error 'dynamic-parse-named-let "Illegal named let-expression: ~s" args)))
|
||||
(error "Illegal named let-expression: " args)))
|
||||
|
||||
|
||||
; dynamic-parse-parallel-bindings
|
||||
|
|
@ -515,8 +517,7 @@
|
|||
(exprs-asg
|
||||
(dynamic-parse-expression* env (map cadr bindings))))
|
||||
(cons nenv (cons bresults exprs-asg)))
|
||||
(error 'dynamic-parse-parallel-bindings
|
||||
"Not a list of bindings: ~s" bindings)))
|
||||
(error "Not a list of bindings: " bindings)))
|
||||
|
||||
|
||||
; dynamic-parse-let*
|
||||
|
|
@ -531,7 +532,7 @@
|
|||
(dynamic-parse-action-let*-expression
|
||||
bresults
|
||||
(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
|
||||
|
||||
|
|
@ -565,10 +566,8 @@
|
|||
(cons bres var-defs)
|
||||
(cons new-expr-asg expr-asgs)
|
||||
(cdr binds)))
|
||||
(error 'dynamic-parse-sequential-bindings
|
||||
"Illegal binding: ~s" fst-bind))))
|
||||
(else (error 'dynamic-parse-sequential-bindings
|
||||
"Illegal bindings: ~s" binds))))))
|
||||
(error "Illegal binding: " fst-bind))))
|
||||
(else (error "Illegal bindings: " binds))))))
|
||||
(let ((env-vdefs-easgs (psb dynamic-empty-env env '() '() bindings)))
|
||||
(cons (car env-vdefs-easgs)
|
||||
(cons (reverse (cadr env-vdefs-easgs))
|
||||
|
|
@ -587,7 +586,7 @@
|
|||
(dynamic-parse-action-letrec-expression
|
||||
bresults
|
||||
(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
|
||||
|
||||
|
|
@ -607,7 +606,7 @@
|
|||
(cons
|
||||
formals-env
|
||||
(cons formals-res exprs-asg)))
|
||||
(error 'dynamic-parse-recursive-bindings "Illegal bindings: ~s" bindings)))
|
||||
(error "Illegal bindings: " bindings)))
|
||||
|
||||
|
||||
; dynamic-parse-do
|
||||
|
|
@ -615,13 +614,13 @@
|
|||
(define (dynamic-parse-do env args)
|
||||
;; parses do-expressions
|
||||
;; ***Note***: Not implemented!
|
||||
(error 'dynamic-parse-do "Nothing yet..."))
|
||||
(error "Nothing yet..."))
|
||||
|
||||
; dynamic-parse-quasiquote
|
||||
|
||||
(define (dynamic-parse-quasiquote env args)
|
||||
;; ***Note***: Not implemented!
|
||||
(error 'dynamic-parse-quasiquote "Nothing yet..."))
|
||||
(error "Nothing yet..."))
|
||||
|
||||
|
||||
;; Command
|
||||
|
|
@ -646,7 +645,7 @@
|
|||
;; parses a sequence of commands
|
||||
(if (list? 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
|
||||
|
|
@ -664,7 +663,7 @@
|
|||
(dynamic-parse-action-definition
|
||||
(dynamic-parse-variable env pattern)
|
||||
(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)
|
||||
(let* ((function-name (car pattern))
|
||||
(function-arg-names (cdr pattern))
|
||||
|
|
@ -675,8 +674,8 @@
|
|||
(dynamic-parse-variable env function-name)
|
||||
formals-ast
|
||||
(dynamic-parse-body (extend-env-with-env env formals-env) exp-or-body))))
|
||||
(else (error 'dynamic-parse-define "Not a valid pattern: ~s" pattern))))
|
||||
(error 'dynamic-parse-define "Not a valid definition: ~s" args)))
|
||||
(else (error "Not a valid pattern: " pattern))))
|
||||
(error "Not a valid definition: " args)))
|
||||
|
||||
;; Auxiliary routines
|
||||
|
||||
|
|
@ -1094,7 +1093,7 @@
|
|||
(inst-tvar (tv-func new-tvar))
|
||||
(inst-def (tvar-def inst-tvar)))
|
||||
(if (null? inst-def)
|
||||
(error 'fix "Illegal recursive type: ~s"
|
||||
(error "Illegal recursive type: "
|
||||
(list (tvar-show new-tvar) '= (tvar-show inst-tvar)))
|
||||
(begin
|
||||
(set-def! new-tvar
|
||||
|
|
@ -1492,8 +1491,8 @@
|
|||
(map ast-show (cdr syntax-arg)))))
|
||||
((23) (cons 'begin
|
||||
(map ast-show syntax-arg)))
|
||||
((24) (error 'ast-show "Do expressions not handled! (~s)" syntax-arg))
|
||||
((25) (error 'ast-show "This can't happen: empty encountered!"))
|
||||
((24) (error "Do expressions not handled! " syntax-arg))
|
||||
((25) (error "This can't happen: empty encountered!"))
|
||||
((26) (list 'define
|
||||
(ast-show (car syntax-arg))
|
||||
(ast-show (cdr syntax-arg))))
|
||||
|
|
@ -1504,7 +1503,7 @@
|
|||
(map ast-show (cddr syntax-arg)))))
|
||||
((28) (cons 'begin
|
||||
(map ast-show syntax-arg)))
|
||||
(else (error 'ast-show "Unknown abstract syntax operator: ~s"
|
||||
(else (error "Unknown abstract syntax operator: "
|
||||
syntax-op)))))
|
||||
|
||||
|
||||
|
|
@ -1523,7 +1522,7 @@
|
|||
((0 1 2 3 4 5) (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)))))
|
||||
(else (error 'datum-show "This should not happen!"))))
|
||||
(else (error "This should not happen!"))))
|
||||
|
||||
; write-to-port
|
||||
|
||||
|
|
@ -1634,8 +1633,7 @@
|
|||
named-var-type)
|
||||
body-type))
|
||||
((23) (ast-tvar (tail arg)))
|
||||
((24) (error 'ast-gen
|
||||
"Do-expressions not handled! (Argument: ~s) arg"))
|
||||
((24) (error "Do-expressions not handled!"))
|
||||
((25) (gen-tvar))
|
||||
((26) (let ((t-var (ast-tvar (car arg)))
|
||||
(t-exp (ast-tvar (cdr arg))))
|
||||
|
|
@ -1647,7 +1645,7 @@
|
|||
(add-constr! (procedure t-formals t-body) t-var)
|
||||
t-var))
|
||||
((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))))
|
||||
|
||||
(define ast-con car)
|
||||
|
|
@ -1676,7 +1674,7 @@
|
|||
((null? tvar-list) (null))
|
||||
((pair? tvar-list) (pair (car 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
|
||||
|
|
@ -1762,8 +1760,8 @@
|
|||
(map tast-show (cdr syntax-arg)))))
|
||||
((23) (cons 'begin
|
||||
(map tast-show syntax-arg)))
|
||||
((24) (error 'tast-show "Do expressions not handled! (~s)" syntax-arg))
|
||||
((25) (error 'tast-show "This can't happen: empty encountered!"))
|
||||
((24) (error "Do expressions not handled! " syntax-arg))
|
||||
((25) (error "This can't happen: empty encountered!"))
|
||||
((26) (list 'define
|
||||
(tast-show (car syntax-arg))
|
||||
(tast-show (cdr syntax-arg))))
|
||||
|
|
@ -1774,7 +1772,7 @@
|
|||
(map tast-show (cddr syntax-arg)))))
|
||||
((28) (cons 'begin
|
||||
(map tast-show syntax-arg)))
|
||||
(else (error 'tast-show "Unknown abstract syntax operator: ~s"
|
||||
(else (error "Unknown abstract syntax operator: "
|
||||
syntax-op)))
|
||||
syntax-tvar)))
|
||||
|
||||
|
|
@ -1948,8 +1946,8 @@
|
|||
(map tag-ast-show (cdr syntax-arg)))))
|
||||
((23) (cons 'begin
|
||||
(map tag-ast-show syntax-arg)))
|
||||
((24) (error 'tag-ast-show "Do expressions not handled! (~s)" syntax-arg))
|
||||
((25) (error 'tag-ast-show "This can't happen: empty encountered!"))
|
||||
((24) (error "Do expressions not handled! " syntax-arg))
|
||||
((25) (error "This can't happen: empty encountered!"))
|
||||
((26) (list 'define
|
||||
(tag-ast-show (car syntax-arg))
|
||||
(tag-ast-show (cdr syntax-arg))))
|
||||
|
|
@ -1962,7 +1960,7 @@
|
|||
(map tag-ast-show (cddr syntax-arg))))))))
|
||||
((28) (cons 'begin
|
||||
(map tag-ast-show syntax-arg)))
|
||||
(else (error 'tag-ast-show "Unknown abstract syntax operator: ~s"
|
||||
(else (error "Unknown abstract syntax operator: "
|
||||
syntax-op)))))
|
||||
|
||||
|
||||
|
|
@ -2324,8 +2322,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 input1)
|
||||
(name "dynamic"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (doit (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -123,9 +123,9 @@
|
|||
; Enders of V = (5 19 20)
|
||||
; Predictors of V = (15 17)
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (make-parser grammar lexer)
|
||||
|
||||
|
|
@ -655,8 +655,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "earley"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (test (hide count (vector->list (make-vector input1 'a)))))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -18,10 +18,9 @@
|
|||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
; Returns a list with n elements, all equal to x.
|
||||
|
||||
|
|
@ -148,7 +147,7 @@
|
|||
(s1 (number->string input1))
|
||||
(s0 (number->string input0))
|
||||
(name "equal"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s0 ":" s1 ":" s2 ":" s3 ":" s4 ":" s5)
|
||||
1
|
||||
(lambda ()
|
||||
|
|
@ -159,3 +158,5 @@
|
|||
(hide input0 input4)
|
||||
(hide input0 input5)))
|
||||
(lambda (result) (eq? result #t)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
;;; FFT - Fast Fourier Transform, translated from "Numerical Recipes in C"
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme inexact)
|
||||
(scheme write)
|
||||
(scheme read))
|
||||
|
||||
;(define flsin sin)
|
||||
(define div quotient)
|
||||
|
||||
(define (four1 data)
|
||||
(let ((n (vector-length data))
|
||||
|
|
@ -33,12 +34,12 @@
|
|||
(let loop3 ((mmax 2))
|
||||
(if (< mmax n)
|
||||
(let* ((theta
|
||||
(fl/ pi*2 (inexact mmax)))
|
||||
(/ pi*2 (inexact mmax)))
|
||||
(wpr
|
||||
(let ((x (flsin (fl* 0.5 theta))))
|
||||
(fl* -2.0 (fl* x x))))
|
||||
(let ((x (sin (* 0.5 theta))))
|
||||
(* -2.0 (* x x))))
|
||||
(wpi
|
||||
(flsin theta)))
|
||||
(sin theta)))
|
||||
(let loop4 ((wr 1.0) (wi 0.0) (m 0))
|
||||
(if (< m mmax)
|
||||
(begin
|
||||
|
|
@ -47,24 +48,24 @@
|
|||
(let* ((j
|
||||
(+ i mmax))
|
||||
(tempr
|
||||
(fl-
|
||||
(fl* wr (vector-ref data j))
|
||||
(fl* wi (vector-ref data (+ j 1)))))
|
||||
(-
|
||||
(* wr (vector-ref data j))
|
||||
(* wi (vector-ref data (+ j 1)))))
|
||||
(tempi
|
||||
(fl+
|
||||
(fl* wr (vector-ref data (+ j 1)))
|
||||
(fl* wi (vector-ref data j)))))
|
||||
(+
|
||||
(* wr (vector-ref data (+ j 1)))
|
||||
(* wi (vector-ref data j)))))
|
||||
(vector-set! data j
|
||||
(fl- (vector-ref data i) tempr))
|
||||
(- (vector-ref data i) tempr))
|
||||
(vector-set! data (+ j 1)
|
||||
(fl- (vector-ref data (+ i 1)) tempi))
|
||||
(- (vector-ref data (+ i 1)) tempi))
|
||||
(vector-set! data i
|
||||
(fl+ (vector-ref data i) tempr))
|
||||
(+ (vector-ref data i) tempr))
|
||||
(vector-set! data (+ i 1)
|
||||
(fl+ (vector-ref data (+ i 1)) tempi))
|
||||
(+ (vector-ref data (+ i 1)) tempi))
|
||||
(loop5 (+ j mmax)));***))
|
||||
(loop4 (fl+ (fl- (fl* wr wpr) (fl* wi wpi)) wr)
|
||||
(fl+ (fl+ (fl* wi wpr) (fl* wr wpi)) wi)
|
||||
(loop4 (+ (- (* wr wpr) (* wi wpi)) wr)
|
||||
(+ (+ (* wi wpr) (* wr wpi)) wi)
|
||||
(+ m 2)))))
|
||||
));******
|
||||
(loop3 (* mmax 2)))))))
|
||||
|
|
@ -84,9 +85,11 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "fft"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda ()
|
||||
(run (hide count (make-vector input1 input2))))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
;;; FIB -- A classic benchmark, computes fib(n) inefficiently.
|
||||
|
||||
(import (rnrs base) (rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (fib n)
|
||||
(if (< n 2)
|
||||
|
|
@ -15,8 +17,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input))
|
||||
(name "fib"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (fib (hide count input)))
|
||||
(lambda (result) (= result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
;;; FIBC -- FIB using first-class continuations, written by Kent Dybvig
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (succ n) (+ n 1))
|
||||
(define (pred n) (- n 1))
|
||||
|
|
@ -31,8 +32,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input))
|
||||
(name "fibc"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (fibc (hide count input) (hide count (lambda (n) n))))
|
||||
(lambda (result) (= result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -32,11 +32,11 @@
|
|||
; of free memory. There is no portable way to do this in Scheme; each
|
||||
; implementation needs its own version.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs records procedural)
|
||||
(rnrs io simple)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define div quotient)
|
||||
|
||||
(define (run-benchmark2 name thunk)
|
||||
(display name)
|
||||
|
|
@ -48,6 +48,13 @@
|
|||
(display " Free memory= ???????? bytes")
|
||||
(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)
|
||||
|
||||
; Nodes used by a tree of a given size
|
||||
|
|
@ -75,21 +82,10 @@
|
|||
|
||||
; Elements 3 and 4 of the allocated vectors are useless.
|
||||
|
||||
(let* ((classNode
|
||||
(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)))
|
||||
(let* ((make-empty-node (lambda () (make-node-raw 0 0 0 0)))
|
||||
(make-node
|
||||
(lambda (l r)
|
||||
(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)))
|
||||
(make-node-raw l r 0 0))))
|
||||
|
||||
; Build tree top down, assigning to older objects.
|
||||
(define (Populate iDepth thisNode)
|
||||
|
|
@ -195,8 +191,10 @@
|
|||
(newline)
|
||||
(display "The use of more or less memory will skew the results.")
|
||||
(newline)
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (gcbench (hide count input1)))
|
||||
(lambda (result) #t))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
;;; GRAPHS -- Obtained from Andrew Wright.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
;;; ==== util.ss ====
|
||||
|
||||
|
|
@ -606,8 +606,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "graphs"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (length (run (hide count input1))))
|
||||
(lambda (result) (= result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
;;; LATTICE -- Obtained from Andrew Wright.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs))
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme read))
|
||||
|
||||
; Given a comparison routine that returns one of
|
||||
; less
|
||||
|
|
@ -233,8 +232,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "lattice"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (run (hide count input1)))
|
||||
(lambda (result) (= result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
;;; MATRIX -- Obtained from Andrew Wright.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define div quotient)
|
||||
(define mod modulo)
|
||||
|
||||
; Chez-Scheme compatibility stuff:
|
||||
|
||||
|
|
@ -759,8 +761,10 @@
|
|||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "matrix"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3)
|
||||
count
|
||||
(lambda () (really-go (hide count input1) (hide count input2)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
;;; MAZEFUN -- Constructs a maze in a purely functional way,
|
||||
;;; written by Marc Feeley.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define mod modulo)
|
||||
|
||||
(define foldr
|
||||
(lambda (f base lst)
|
||||
|
|
@ -195,8 +197,10 @@
|
|||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "mazefun"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3)
|
||||
count
|
||||
(lambda () (make-maze (hide count input1) (hide count input2)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,28 +1,28 @@
|
|||
;;; MBROT -- Generation of Mandelbrot set fractal.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (count r i step x y)
|
||||
|
||||
(let ((max-count 64)
|
||||
(radius^2 16.0))
|
||||
|
||||
(let ((cr (fl+ r (fl* (inexact x) step)))
|
||||
(ci (fl+ i (fl* (inexact y) step))))
|
||||
(let ((cr (+ r (* (inexact x) step)))
|
||||
(ci (+ i (* (inexact y) step))))
|
||||
|
||||
(let loop ((zr cr)
|
||||
(zi ci)
|
||||
(c 0))
|
||||
(if (= c max-count)
|
||||
c
|
||||
(let ((zr^2 (fl* zr zr))
|
||||
(zi^2 (fl* zi zi)))
|
||||
(if (fl>? (fl+ zr^2 zi^2) radius^2)
|
||||
(let ((zr^2 (* zr zr))
|
||||
(zi^2 (* zi zi)))
|
||||
(if (> (+ zr^2 zi^2) radius^2)
|
||||
c
|
||||
(let ((new-zr (fl+ (fl- zr^2 zi^2) cr))
|
||||
(new-zi (fl+ (fl* 2.0 (fl* zr zi)) ci)))
|
||||
(let ((new-zr (+ (- zr^2 zi^2) cr))
|
||||
(new-zi (+ (* 2.0 (* zr zi)) ci)))
|
||||
(loop new-zr new-zi (+ c 1))))))))))
|
||||
|
||||
(define (mbrot matrix r i step n)
|
||||
|
|
@ -52,8 +52,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "mbrot"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (test (hide count input1)))
|
||||
(lambda (result) (= result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
;;; MBROT -- Generation of Mandelbrot set fractal
|
||||
;;; using Scheme's complex numbers.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme complex))
|
||||
|
||||
(define (count z0 step z)
|
||||
|
||||
(let* ((max-count 64)
|
||||
(radius 4.0)
|
||||
(radius^2 (fl* radius radius)))
|
||||
(radius^2 (* radius radius)))
|
||||
|
||||
(let ((z0 (+ z0 (* z step))))
|
||||
|
||||
|
|
@ -19,9 +20,9 @@
|
|||
c
|
||||
(let* ((zr (real-part z))
|
||||
(zi (imag-part z))
|
||||
(zr^2 (fl* zr zr))
|
||||
(zi^2 (fl* zi zi)))
|
||||
(if (fl>? (fl+ zr^2 zi^2) radius^2)
|
||||
(zr^2 (* zr zr))
|
||||
(zi^2 (* zi zi)))
|
||||
(if (> (+ zr^2 zi^2) radius^2)
|
||||
c
|
||||
(loop (+ (* z z) z0) (+ c 1)))))))))
|
||||
|
||||
|
|
@ -57,8 +58,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "mbrotZ"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (test (hide count input1)))
|
||||
(lambda (result) (= result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -13,9 +13,9 @@
|
|||
; 000820 / wdc Added the MpermNKL benchmark; revised for new run-benchmark.
|
||||
; 071127 / wdc Simplified and ported for R6RS.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
; This benchmark is in three parts. Each tests a different aspect of
|
||||
; the memory system.
|
||||
|
|
@ -193,7 +193,7 @@
|
|||
(newline))))
|
||||
|
||||
(define (run-benchmark . args)
|
||||
(apply run-r6rs-benchmark args))
|
||||
(apply run-r7rs-benchmark args))
|
||||
|
||||
(define (main)
|
||||
(let* ((input1 (read))
|
||||
|
|
@ -210,3 +210,5 @@
|
|||
(hide input1 input2)
|
||||
(hide input1 input3)
|
||||
(hide input1 input4))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -55,10 +55,10 @@
|
|||
; The second phase creates the test problem, and tests to see
|
||||
; whether it is implied by the lemmas.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme cxr))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
|
|
@ -67,7 +67,7 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input))
|
||||
(name "nboyer"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda ()
|
||||
|
|
@ -773,3 +773,5 @@
|
|||
(if answer
|
||||
rewrite-count
|
||||
#f)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
;;; NQUEENS -- Compute number of solutions to 8-queens problem.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define trace? #f)
|
||||
|
||||
|
|
@ -37,8 +38,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "nqueens"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (nqueens (hide count input1)))
|
||||
(lambda (result) (= result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
;;; NTAKL -- The TAKeuchi function using lists as counters,
|
||||
;;; with an alternative boolean expression.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (listn n)
|
||||
(if (= n 0)
|
||||
|
|
@ -51,9 +52,11 @@
|
|||
(s2 (number->string (length input2)))
|
||||
(s1 (number->string (length input1)))
|
||||
(name "ntakl"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3 ":" s4)
|
||||
count
|
||||
(lambda ()
|
||||
(mas (hide count input1) (hide count input2) (hide count input3)))
|
||||
(lambda (result) (equal? (length result) output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -18,9 +18,11 @@
|
|||
|
||||
; -- MATH UTILITIES -----------------------------------------------------------
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme cxr)
|
||||
(scheme inexact))
|
||||
|
||||
(define-syntax nuc-const
|
||||
(syntax-rules ()
|
||||
|
|
@ -32,16 +34,16 @@
|
|||
(define constant-minus-pi/2 -1.57079632679489661923)
|
||||
|
||||
(define (math-atan2 y x)
|
||||
(cond ((fl>? x 0.0)
|
||||
(flatan (fl/ y x)))
|
||||
((fl<? y 0.0)
|
||||
(if (fl=? x 0.0)
|
||||
(cond ((> x 0.0)
|
||||
(atan (/ y x)))
|
||||
((< y 0.0)
|
||||
(if (= x 0.0)
|
||||
constant-minus-pi/2
|
||||
(fl+ (flatan (fl/ y x)) constant-minus-pi)))
|
||||
(+ (atan (/ y x)) constant-minus-pi)))
|
||||
(else
|
||||
(if (fl=? x 0.0)
|
||||
(if (= x 0.0)
|
||||
constant-pi/2
|
||||
(fl+ (flatan (fl/ y x)) constant-pi)))))
|
||||
(+ (atan (/ y x)) constant-pi)))))
|
||||
|
||||
; -- POINTS -------------------------------------------------------------------
|
||||
|
||||
|
|
@ -56,22 +58,22 @@
|
|||
(define (pt-z-set! pt val) (vector-set! pt 2 val))
|
||||
|
||||
(define (pt-sub p1 p2)
|
||||
(make-pt (fl- (pt-x p1) (pt-x p2))
|
||||
(fl- (pt-y p1) (pt-y p2))
|
||||
(fl- (pt-z p1) (pt-z p2))))
|
||||
(make-pt (- (pt-x p1) (pt-x p2))
|
||||
(- (pt-y p1) (pt-y p2))
|
||||
(- (pt-z p1) (pt-z p2))))
|
||||
|
||||
(define (pt-dist p1 p2)
|
||||
(let ((dx (fl- (pt-x p1) (pt-x p2)))
|
||||
(dy (fl- (pt-y p1) (pt-y p2)))
|
||||
(dz (fl- (pt-z p1) (pt-z p2))))
|
||||
(flsqrt (fl+ (fl* dx dx) (fl* dy dy) (fl* dz dz)))))
|
||||
(let ((dx (- (pt-x p1) (pt-x p2)))
|
||||
(dy (- (pt-y p1) (pt-y p2)))
|
||||
(dz (- (pt-z p1) (pt-z p2))))
|
||||
(sqrt (+ (* dx dx) (* dy dy) (* dz dz)))))
|
||||
|
||||
(define (pt-phi p)
|
||||
(let* ((x (pt-x p))
|
||||
(y (pt-y p))
|
||||
(z (pt-z p))
|
||||
(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)
|
||||
(math-atan2 (pt-x p) (pt-z p)))
|
||||
|
|
@ -136,17 +138,17 @@
|
|||
(y (pt-y p))
|
||||
(z (pt-z p)))
|
||||
(make-pt
|
||||
(fl+ (fl* x (tfo-a tfo))
|
||||
(fl* y (tfo-d tfo))
|
||||
(fl* z (tfo-g tfo))
|
||||
(+ (* x (tfo-a tfo))
|
||||
(* y (tfo-d tfo))
|
||||
(* z (tfo-g tfo))
|
||||
(tfo-tx tfo))
|
||||
(fl+ (fl* x (tfo-b tfo))
|
||||
(fl* y (tfo-e tfo))
|
||||
(fl* z (tfo-h tfo))
|
||||
(+ (* x (tfo-b tfo))
|
||||
(* y (tfo-e tfo))
|
||||
(* z (tfo-h tfo))
|
||||
(tfo-ty tfo))
|
||||
(fl+ (fl* x (tfo-c tfo))
|
||||
(fl* y (tfo-f tfo))
|
||||
(fl* z (tfo-i tfo))
|
||||
(+ (* x (tfo-c tfo))
|
||||
(* y (tfo-f tfo))
|
||||
(* z (tfo-i tfo))
|
||||
(tfo-tz tfo)))))
|
||||
|
||||
; The function "tfo-combine" multiplies two transformation matrices A and B.
|
||||
|
|
@ -155,44 +157,44 @@
|
|||
|
||||
(define (tfo-combine A B)
|
||||
(make-tfo
|
||||
(fl+ (fl* (tfo-a A) (tfo-a B))
|
||||
(fl* (tfo-b A) (tfo-d B))
|
||||
(fl* (tfo-c A) (tfo-g B)))
|
||||
(fl+ (fl* (tfo-a A) (tfo-b B))
|
||||
(fl* (tfo-b A) (tfo-e B))
|
||||
(fl* (tfo-c A) (tfo-h B)))
|
||||
(fl+ (fl* (tfo-a A) (tfo-c B))
|
||||
(fl* (tfo-b A) (tfo-f B))
|
||||
(fl* (tfo-c A) (tfo-i B)))
|
||||
(fl+ (fl* (tfo-d A) (tfo-a B))
|
||||
(fl* (tfo-e A) (tfo-d B))
|
||||
(fl* (tfo-f A) (tfo-g B)))
|
||||
(fl+ (fl* (tfo-d A) (tfo-b B))
|
||||
(fl* (tfo-e A) (tfo-e B))
|
||||
(fl* (tfo-f A) (tfo-h B)))
|
||||
(fl+ (fl* (tfo-d A) (tfo-c B))
|
||||
(fl* (tfo-e A) (tfo-f B))
|
||||
(fl* (tfo-f A) (tfo-i B)))
|
||||
(fl+ (fl* (tfo-g A) (tfo-a B))
|
||||
(fl* (tfo-h A) (tfo-d B))
|
||||
(fl* (tfo-i A) (tfo-g B)))
|
||||
(fl+ (fl* (tfo-g A) (tfo-b B))
|
||||
(fl* (tfo-h A) (tfo-e B))
|
||||
(fl* (tfo-i A) (tfo-h B)))
|
||||
(fl+ (fl* (tfo-g A) (tfo-c B))
|
||||
(fl* (tfo-h A) (tfo-f B))
|
||||
(fl* (tfo-i A) (tfo-i B)))
|
||||
(fl+ (fl* (tfo-tx A) (tfo-a B))
|
||||
(fl* (tfo-ty A) (tfo-d B))
|
||||
(fl* (tfo-tz A) (tfo-g B))
|
||||
(+ (* (tfo-a A) (tfo-a B))
|
||||
(* (tfo-b A) (tfo-d B))
|
||||
(* (tfo-c A) (tfo-g B)))
|
||||
(+ (* (tfo-a A) (tfo-b B))
|
||||
(* (tfo-b A) (tfo-e B))
|
||||
(* (tfo-c A) (tfo-h B)))
|
||||
(+ (* (tfo-a A) (tfo-c B))
|
||||
(* (tfo-b A) (tfo-f B))
|
||||
(* (tfo-c A) (tfo-i B)))
|
||||
(+ (* (tfo-d A) (tfo-a B))
|
||||
(* (tfo-e A) (tfo-d B))
|
||||
(* (tfo-f A) (tfo-g B)))
|
||||
(+ (* (tfo-d A) (tfo-b B))
|
||||
(* (tfo-e A) (tfo-e B))
|
||||
(* (tfo-f A) (tfo-h B)))
|
||||
(+ (* (tfo-d A) (tfo-c B))
|
||||
(* (tfo-e A) (tfo-f B))
|
||||
(* (tfo-f A) (tfo-i B)))
|
||||
(+ (* (tfo-g A) (tfo-a B))
|
||||
(* (tfo-h A) (tfo-d B))
|
||||
(* (tfo-i A) (tfo-g B)))
|
||||
(+ (* (tfo-g A) (tfo-b B))
|
||||
(* (tfo-h A) (tfo-e B))
|
||||
(* (tfo-i A) (tfo-h B)))
|
||||
(+ (* (tfo-g A) (tfo-c B))
|
||||
(* (tfo-h A) (tfo-f B))
|
||||
(* (tfo-i A) (tfo-i B)))
|
||||
(+ (* (tfo-tx A) (tfo-a B))
|
||||
(* (tfo-ty A) (tfo-d B))
|
||||
(* (tfo-tz A) (tfo-g B))
|
||||
(tfo-tx B))
|
||||
(fl+ (fl* (tfo-tx A) (tfo-b B))
|
||||
(fl* (tfo-ty A) (tfo-e B))
|
||||
(fl* (tfo-tz A) (tfo-h B))
|
||||
(+ (* (tfo-tx A) (tfo-b B))
|
||||
(* (tfo-ty A) (tfo-e B))
|
||||
(* (tfo-tz A) (tfo-h B))
|
||||
(tfo-ty B))
|
||||
(fl+ (fl* (tfo-tx A) (tfo-c B))
|
||||
(fl* (tfo-ty A) (tfo-f B))
|
||||
(fl* (tfo-tz A) (tfo-i B))
|
||||
(+ (* (tfo-tx A) (tfo-c B))
|
||||
(* (tfo-ty A) (tfo-f B))
|
||||
(* (tfo-tz A) (tfo-i B))
|
||||
(tfo-tz B))))
|
||||
|
||||
; 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-b tfo) (tfo-e tfo) (tfo-h tfo)
|
||||
(tfo-c tfo) (tfo-f tfo) (tfo-i tfo)
|
||||
(fl- (fl+ (fl* (tfo-a tfo) tx)
|
||||
(fl* (tfo-b tfo) ty)
|
||||
(fl* (tfo-c tfo) tz)))
|
||||
(fl- (fl+ (fl* (tfo-d tfo) tx)
|
||||
(fl* (tfo-e tfo) ty)
|
||||
(fl* (tfo-f tfo) tz)))
|
||||
(fl- (fl+ (fl* (tfo-g tfo) tx)
|
||||
(fl* (tfo-h tfo) ty)
|
||||
(fl* (tfo-i tfo) tz))))))
|
||||
(- (+ (* (tfo-a tfo) tx)
|
||||
(* (tfo-b tfo) ty)
|
||||
(* (tfo-c tfo) tz)))
|
||||
(- (+ (* (tfo-d tfo) tx)
|
||||
(* (tfo-e tfo) ty)
|
||||
(* (tfo-f tfo) tz)))
|
||||
(- (+ (* (tfo-g tfo) tx)
|
||||
(* (tfo-h tfo) ty)
|
||||
(* (tfo-i tfo) tz))))))
|
||||
|
||||
; 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
|
||||
|
|
@ -223,52 +225,52 @@
|
|||
(define (tfo-align p1 p2 p3)
|
||||
(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))
|
||||
(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))
|
||||
(Phi (pt-phi rotpY))
|
||||
(Theta (pt-theta rotpY))
|
||||
(sinP (flsin Phi))
|
||||
(sinT (flsin Theta))
|
||||
(cosP (flcos Phi))
|
||||
(cosT (flcos Theta))
|
||||
(sinPsinT (fl* sinP sinT))
|
||||
(sinPcosT (fl* sinP cosT))
|
||||
(cosPsinT (fl* cosP sinT))
|
||||
(cosPcosT (fl* cosP cosT))
|
||||
(sinP (sin Phi))
|
||||
(sinT (sin Theta))
|
||||
(cosP (cos Phi))
|
||||
(cosT (cos Theta))
|
||||
(sinPsinT (* sinP sinT))
|
||||
(sinPcosT (* sinP cosT))
|
||||
(cosPsinT (* cosP sinT))
|
||||
(cosPcosT (* cosP cosT))
|
||||
(rotpZ
|
||||
(make-pt
|
||||
(fl- (fl* cosT x31)
|
||||
(fl* sinT z31))
|
||||
(fl+ (fl* sinPsinT x31)
|
||||
(fl* cosP y31)
|
||||
(fl* sinPcosT z31))
|
||||
(fl+ (fl* cosPsinT x31)
|
||||
(fl- (fl* sinP y31))
|
||||
(fl* cosPcosT z31))))
|
||||
(- (* cosT x31)
|
||||
(* sinT z31))
|
||||
(+ (* sinPsinT x31)
|
||||
(* cosP y31)
|
||||
(* sinPcosT z31))
|
||||
(+ (* cosPsinT x31)
|
||||
(- (* sinP y31))
|
||||
(* cosPcosT z31))))
|
||||
(Rho (pt-theta rotpZ))
|
||||
(cosR (flcos Rho))
|
||||
(sinR (flsin Rho))
|
||||
(x (fl+ (fl- (fl* x1 cosT))
|
||||
(fl* z1 sinT)))
|
||||
(y (fl- (fl- (fl- (fl* x1 sinPsinT))
|
||||
(fl* y1 cosP))
|
||||
(fl* z1 sinPcosT)))
|
||||
(z (fl- (fl+ (fl- (fl* x1 cosPsinT))
|
||||
(fl* y1 sinP))
|
||||
(fl* z1 cosPcosT))))
|
||||
(cosR (cos Rho))
|
||||
(sinR (sin Rho))
|
||||
(x (+ (- (* x1 cosT))
|
||||
(* z1 sinT)))
|
||||
(y (- (- (- (* x1 sinPsinT))
|
||||
(* y1 cosP))
|
||||
(* z1 sinPcosT)))
|
||||
(z (- (+ (- (* x1 cosPsinT))
|
||||
(* y1 sinP))
|
||||
(* z1 cosPcosT))))
|
||||
(make-tfo
|
||||
(fl- (fl* cosT cosR) (fl* cosPsinT sinR))
|
||||
(- (* cosT cosR) (* cosPsinT sinR))
|
||||
sinPsinT
|
||||
(fl+ (fl* cosT sinR) (fl* cosPsinT cosR))
|
||||
(fl* sinP sinR)
|
||||
(+ (* cosT sinR) (* cosPsinT cosR))
|
||||
(* sinP sinR)
|
||||
cosP
|
||||
(fl- (fl* sinP cosR))
|
||||
(fl- (fl- (fl* sinT cosR)) (fl* cosPcosT sinR))
|
||||
(- (* sinP cosR))
|
||||
(- (- (* sinT cosR)) (* cosPcosT sinR))
|
||||
sinPcosT
|
||||
(fl+ (fl- (fl* sinT sinR)) (fl* cosPcosT cosR))
|
||||
(fl- (fl* x cosR) (fl* z sinR))
|
||||
(+ (- (* sinT sinR)) (* cosPcosT cosR))
|
||||
(- (* x cosR) (* z sinR))
|
||||
y
|
||||
(fl+ (fl* x sinR) (fl* z cosR)))))
|
||||
(+ (* x sinR) (* z cosR)))))
|
||||
|
||||
; -- NUCLEIC ACID CONFORMATIONS DATA BASE -------------------------------------
|
||||
|
||||
|
|
@ -3313,7 +3315,7 @@
|
|||
(if (= (var-id v) 33)
|
||||
(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
|
||||
(fl<=? (pt-dist p o3*) 3.0)) ; check distance
|
||||
(<= (pt-dist p o3*) 3.0)) ; check distance
|
||||
#t))
|
||||
|
||||
(define (anticodon)
|
||||
|
|
@ -3361,11 +3363,11 @@
|
|||
((18)
|
||||
(let ((p (atom-pos nuc-P (get-var 19 partial-inst)))
|
||||
(o3* (atom-pos nuc-O3* v)))
|
||||
(fl<=? (pt-dist p o3*) 4.0)))
|
||||
(<= (pt-dist p o3*) 4.0)))
|
||||
((6)
|
||||
(let ((p (atom-pos nuc-P (get-var 7 partial-inst)))
|
||||
(o3* (atom-pos nuc-O3* v)))
|
||||
(fl<=? (pt-dist p o3*) 4.5)))
|
||||
(<= (pt-dist p o3*) 4.5)))
|
||||
(else
|
||||
#t)))
|
||||
|
||||
|
|
@ -3449,7 +3451,7 @@
|
|||
(define (distance 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)))
|
||||
(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)))))
|
||||
|
||||
|
|
@ -3464,7 +3466,7 @@
|
|||
(if (null? l)
|
||||
m
|
||||
(let ((x (car l)))
|
||||
(loop (if (fl>? x m) x m) (cdr l))))))
|
||||
(loop (if (> x m) x m) (cdr l))))))
|
||||
|
||||
(define (run input)
|
||||
(most-distant-atom (pseudoknot input)))
|
||||
|
|
@ -3476,11 +3478,13 @@
|
|||
(s2 (number->string count))
|
||||
(s1 input1)
|
||||
(name "nucleic"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (run (hide count input1)))
|
||||
(lambda (result)
|
||||
(and (number? result)
|
||||
(let ((x (fl/ result output)))
|
||||
(and (fl>? x 0.999999) (fl<? x 1.000001))))))))
|
||||
(let ((x (/ result output)))
|
||||
(and (> x 0.999999) (< x 1.000001))))))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,10 @@
|
|||
;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define div quotient)
|
||||
|
||||
(define (gen n)
|
||||
(let* ((n/2 (div n 2))
|
||||
|
|
@ -177,8 +180,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "paraffins"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (nb (hide count input1)))
|
||||
(lambda (result) (= result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -30,12 +30,11 @@
|
|||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs unicode)
|
||||
(rnrs lists)
|
||||
(rnrs control)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-strings))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme char))
|
||||
|
||||
(define (parsing-benchmark . rest)
|
||||
(let* ((n (if (null? rest) 1000 (car rest)))
|
||||
|
|
@ -935,8 +934,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 input1)
|
||||
(name "parsing"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
1
|
||||
(lambda () (parsing-benchmark (hide count count) (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
;;; PEVAL -- A simple partial evaluator for Scheme, written by Marc Feeley.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme cxr))
|
||||
|
||||
;------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -636,7 +636,7 @@
|
|||
(s2 (number->string count))
|
||||
(s1 "")
|
||||
(name "peval"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (test (hide count input1) (hide count input2)))
|
||||
|
|
@ -644,3 +644,5 @@
|
|||
(and (list? result)
|
||||
(= (length result) 10)
|
||||
(equal? (list-ref result 9) output))))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -2,8 +2,11 @@
|
|||
|
||||
; See http://mathworld.wolfram.com/Pi.html for the various algorithms.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme read))
|
||||
|
||||
(define div quotient)
|
||||
|
||||
; Utilities.
|
||||
|
||||
|
|
@ -125,7 +128,7 @@
|
|||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "pi"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3 ":" s4)
|
||||
count
|
||||
(lambda ()
|
||||
|
|
@ -133,3 +136,5 @@
|
|||
(hide count input2)
|
||||
(hide count input3)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,24 +1,24 @@
|
|||
;;; PNPOLY - Test if a point is contained in a 2D polygon.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme read))
|
||||
|
||||
(define (pt-in-poly2 xp yp x y)
|
||||
(let loop ((c #f) (i (- (vector-length xp) 1)) (j 0))
|
||||
(if (< i 0)
|
||||
c
|
||||
(if (or (and (or (fl>? (vector-ref yp i) y)
|
||||
(fl>=? y (vector-ref yp j)))
|
||||
(or (fl>? (vector-ref yp j) y)
|
||||
(fl>=? y (vector-ref yp i))))
|
||||
(fl>=? x
|
||||
(fl+ (vector-ref xp i)
|
||||
(fl/ (fl*
|
||||
(fl- (vector-ref xp j)
|
||||
(if (or (and (or (> (vector-ref yp i) y)
|
||||
(>= y (vector-ref yp j)))
|
||||
(or (> (vector-ref yp j) y)
|
||||
(>= y (vector-ref yp i))))
|
||||
(>= x
|
||||
(+ (vector-ref xp i)
|
||||
(/ (*
|
||||
(- (vector-ref xp j)
|
||||
(vector-ref xp i))
|
||||
(fl- y (vector-ref yp i)))
|
||||
(fl- (vector-ref yp j)
|
||||
(- y (vector-ref yp i)))
|
||||
(- (vector-ref yp j)
|
||||
(vector-ref yp i))))))
|
||||
(loop c (- i 1) i)
|
||||
(loop (not c) (- i 1) i)))))
|
||||
|
|
@ -49,8 +49,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 "")
|
||||
(name "pnpoly"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (run (hide count input1) (hide count input2)))
|
||||
(lambda (result) (and (number? result) (= result output))))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,11 @@
|
|||
;;; PRIMES -- Compute primes less than 100, written by Eric Mohr.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define div quotient)
|
||||
(define mod modulo)
|
||||
|
||||
(define (interval-list m n)
|
||||
(if (> m n)
|
||||
|
|
@ -32,8 +36,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "primes"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (primes<= (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme read))
|
||||
|
||||
(define (my-iota n)
|
||||
(do ((n n (- n 1))
|
||||
|
|
@ -144,7 +144,7 @@
|
|||
(s2 (number->string count))
|
||||
(s1 input1)
|
||||
(name "puzzle"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (start (hide count input1)))
|
||||
|
|
@ -152,3 +152,5 @@
|
|||
|
||||
(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
|
||||
(my-iota (+ typemax 1)))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
; This is probably from Lars Hansen's MS thesis.
|
||||
; The quick-1 benchmark. (Figure 35, page 132.)
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (quick-1 v less?)
|
||||
|
||||
|
|
@ -92,32 +91,32 @@
|
|||
(set! random-flonum
|
||||
(lambda ()
|
||||
(let ((seed seed)) ; make it local
|
||||
(let ((p1 (fl- (fl* a12 (vector-ref seed 1))
|
||||
(fl* a13n (vector-ref seed 0))))
|
||||
(p2 (fl- (fl* a21 (vector-ref seed 5))
|
||||
(fl* a23n (vector-ref seed 3)))))
|
||||
(let ((k1 (truncate (fl/ p1 m1)))
|
||||
(k2 (truncate (fl/ p2 m2)))
|
||||
(let ((p1 (- (* a12 (vector-ref seed 1))
|
||||
(* a13n (vector-ref seed 0))))
|
||||
(p2 (- (* a21 (vector-ref seed 5))
|
||||
(* a23n (vector-ref seed 3)))))
|
||||
(let ((k1 (truncate (/ p1 m1)))
|
||||
(k2 (truncate (/ p2 m2)))
|
||||
(ignore1 (vector-set! seed 0 (vector-ref seed 1)))
|
||||
(ignore3 (vector-set! seed 3 (vector-ref seed 4))))
|
||||
(let ((p1 (fl- p1 (fl* k1 m1)))
|
||||
(p2 (fl- p2 (fl* k2 m2)))
|
||||
(let ((p1 (- p1 (* k1 m1)))
|
||||
(p2 (- p2 (* k2 m2)))
|
||||
(ignore2 (vector-set! seed 1 (vector-ref seed 2)))
|
||||
(ignore4 (vector-set! seed 4 (vector-ref seed 5))))
|
||||
(let ((p1 (if (fl<? p1 0.0) (fl+ p1 m1) p1))
|
||||
(p2 (if (fl<? p2 0.0) (fl+ p2 m2) p2)))
|
||||
(let ((p1 (if (< p1 0.0) (+ p1 m1) p1))
|
||||
(p2 (if (< p2 0.0) (+ p2 m2) p2)))
|
||||
(vector-set! seed 2 p1)
|
||||
(vector-set! seed 5 p2)
|
||||
(if (fl<=? p1 p2)
|
||||
(fl* norm (fl+ (fl- p1 p2) m1))
|
||||
(fl* norm (fl- p1 p2))))))))))
|
||||
(if (<= p1 p2)
|
||||
(* norm (+ (- p1 p2) m1))
|
||||
(* norm (- p1 p2))))))))))
|
||||
|
||||
(set! seed-ref (lambda () (vector->list seed)))
|
||||
|
||||
(set! seed-set! (lambda l (set! seed (list->vector l)))))
|
||||
|
||||
(define (random n)
|
||||
(exact (fltruncate (fl* (inexact n) (random-flonum)))))
|
||||
(exact (truncate (* (inexact n) (random-flonum)))))
|
||||
|
||||
;;; Even with the improved random number generator,
|
||||
;;; this benchmark still spends almost all of its time
|
||||
|
|
@ -141,7 +140,7 @@
|
|||
(do ((i 0 (+ i 1)))
|
||||
((= i n))
|
||||
(vector-set! v i (random r)))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s3)
|
||||
count
|
||||
(lambda () (quick-1 (vector-map values v) less?))
|
||||
|
|
@ -154,3 +153,5 @@
|
|||
(if (not (<= (vector-ref v (- i 1))
|
||||
(vector-ref v i)))
|
||||
(return #f)))))))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
;;; 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
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple)
|
||||
(rnrs files)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme read)
|
||||
(scheme file)
|
||||
(scheme inexact))
|
||||
|
||||
(define (make-point x y z)
|
||||
(vector x y z))
|
||||
|
|
@ -14,31 +14,31 @@
|
|||
(define (point-y p) (vector-ref p 1))
|
||||
(define (point-z p) (vector-ref p 2))
|
||||
|
||||
(define (sq x) (fl* x x))
|
||||
(define (sq x) (* x x))
|
||||
|
||||
(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)
|
||||
(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)
|
||||
(mag (fl- (point-x p1) (point-x p2))
|
||||
(fl- (point-y p1) (point-y p2))
|
||||
(fl- (point-z p1) (point-z p2))))
|
||||
(mag (- (point-x p1) (point-x p2))
|
||||
(- (point-y p1) (point-y p2))
|
||||
(- (point-z p1) (point-z p2))))
|
||||
|
||||
(define (minroot a b c)
|
||||
(if (flzero? a)
|
||||
(fl/ (fl- c) b)
|
||||
(let ((disc (fl- (sq b) (fl* 4.0 a c))))
|
||||
(if (flnegative? disc)
|
||||
(if (zero? a)
|
||||
(/ (- c) b)
|
||||
(let ((disc (- (sq b) (* 4.0 a c))))
|
||||
(if (negative? disc)
|
||||
#f
|
||||
(let ((discrt (flsqrt disc))
|
||||
(minus-b (fl- b))
|
||||
(two-a (fl* 2.0 a)))
|
||||
(flmin (fl/ (fl+ minus-b discrt) two-a)
|
||||
(fl/ (fl- minus-b discrt) two-a)))))))
|
||||
(let ((discrt (sqrt disc))
|
||||
(minus-b (- b))
|
||||
(two-a (* 2.0 a)))
|
||||
(min (/ (+ minus-b discrt) two-a)
|
||||
(/ (- minus-b discrt) two-a)))))))
|
||||
|
||||
(define *world* '())
|
||||
|
||||
|
|
@ -62,18 +62,18 @@
|
|||
(do ((x 0 (+ x 1)))
|
||||
((= x extent))
|
||||
(write (color-at
|
||||
(fl+ -50.0
|
||||
(fl/ (inexact x) (inexact res)))
|
||||
(fl+ -50.0
|
||||
(fl/ (inexact y) (inexact res))))
|
||||
(+ -50.0
|
||||
(/ (inexact x) (inexact res)))
|
||||
(+ -50.0
|
||||
(/ (inexact y) (inexact res))))
|
||||
p)
|
||||
(newline p)))))))
|
||||
|
||||
(define (color-at x y)
|
||||
(let ((ray (unit-vector (fl- x (point-x eye))
|
||||
(fl- y (point-y eye))
|
||||
(fl- (point-z eye)))))
|
||||
(exact (flround (fl* (sendray eye ray) 255.0)))))
|
||||
(let ((ray (unit-vector (- x (point-x eye))
|
||||
(- y (point-y eye))
|
||||
(- (point-z eye)))))
|
||||
(exact (round (* (sendray eye ray) 255.0)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -82,7 +82,7 @@
|
|||
(s (vector-ref x 0))
|
||||
(int (vector-ref x 1)))
|
||||
(if s
|
||||
(fl* (lambert s int ray)
|
||||
(* (lambert s int ray)
|
||||
(surface-color s))
|
||||
0.0)))
|
||||
|
||||
|
|
@ -94,17 +94,17 @@
|
|||
(let ((h (intersect s pt ray)))
|
||||
(if h
|
||||
(let ((d (distance h pt)))
|
||||
(if (fl<? d dist)
|
||||
(if (< d dist)
|
||||
(loop (cdr lst) s h d)
|
||||
(loop (cdr lst) surface hit dist)))
|
||||
(loop (cdr lst) surface hit dist)))))))
|
||||
|
||||
(define (lambert s int ray)
|
||||
(let ((n (normal s int)))
|
||||
(flmax 0.0
|
||||
(fl+ (fl* (point-x ray) (point-x n))
|
||||
(fl* (point-y ray) (point-y n))
|
||||
(fl* (point-z ray) (point-z n))))))
|
||||
(max 0.0
|
||||
(+ (* (point-x ray) (point-x n))
|
||||
(* (point-y ray) (point-y n))
|
||||
(* (point-z ray) (point-z n))))))
|
||||
|
||||
(define (make-sphere color radius center)
|
||||
(vector color radius center))
|
||||
|
|
@ -130,19 +130,19 @@
|
|||
(zr (point-z ray))
|
||||
(c (sphere-center s))
|
||||
(n (minroot
|
||||
(fl+ (sq xr) (sq yr) (sq zr))
|
||||
(fl* 2.0
|
||||
(fl+ (fl* (fl- (point-x pt) (point-x c)) xr)
|
||||
(fl* (fl- (point-y pt) (point-y c)) yr)
|
||||
(fl* (fl- (point-z pt) (point-z c)) zr)))
|
||||
(fl+ (sq (fl- (point-x pt) (point-x c)))
|
||||
(sq (fl- (point-y pt) (point-y c)))
|
||||
(sq (fl- (point-z pt) (point-z c)))
|
||||
(fl- (sq (sphere-radius s)))))))
|
||||
(+ (sq xr) (sq yr) (sq zr))
|
||||
(* 2.0
|
||||
(+ (* (- (point-x pt) (point-x c)) xr)
|
||||
(* (- (point-y pt) (point-y c)) yr)
|
||||
(* (- (point-z pt) (point-z c)) zr)))
|
||||
(+ (sq (- (point-x pt) (point-x c)))
|
||||
(sq (- (point-y pt) (point-y c)))
|
||||
(sq (- (point-z pt) (point-z c)))
|
||||
(- (sq (sphere-radius s)))))))
|
||||
(if n
|
||||
(make-point (fl+ (point-x pt) (fl* n xr))
|
||||
(fl+ (point-y pt) (fl* n yr))
|
||||
(fl+ (point-z pt) (fl* n zr)))
|
||||
(make-point (+ (point-x pt) (* n xr))
|
||||
(+ (point-y pt) (* n yr))
|
||||
(+ (point-z pt) (* n zr)))
|
||||
#f)))
|
||||
|
||||
(define (normal s pt)
|
||||
|
|
@ -150,9 +150,9 @@
|
|||
|
||||
(define (sphere-normal s pt)
|
||||
(let ((c (sphere-center s)))
|
||||
(unit-vector (fl- (point-x c) (point-x pt))
|
||||
(fl- (point-y c) (point-y pt))
|
||||
(fl- (point-z c) (point-z pt)))))
|
||||
(unit-vector (- (point-x c) (point-x pt))
|
||||
(- (point-y c) (point-y pt))
|
||||
(- (point-z c) (point-z pt)))))
|
||||
|
||||
(define (ray-test res output-file)
|
||||
(set! *world* '())
|
||||
|
|
@ -164,9 +164,9 @@
|
|||
(do ((z 2 (+ z 1)))
|
||||
((> z 7))
|
||||
(defsphere
|
||||
(fl* (inexact x) 200.0)
|
||||
(* (inexact x) 200.0)
|
||||
300.0
|
||||
(fl* (inexact z) -400.0)
|
||||
(* (inexact z) -400.0)
|
||||
40.0
|
||||
0.75)))
|
||||
(tracer output-file res))
|
||||
|
|
@ -183,8 +183,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "ray"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (run (hide count input1) (hide count input2)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -4,10 +4,10 @@
|
|||
;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io ports)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme file))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
|
|
@ -30,9 +30,9 @@
|
|||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (read-from-file-benchmark input t)
|
||||
(define (read-from-file-benchmark input)
|
||||
(call-with-port
|
||||
(open-file-input-port input (file-options) 'block t)
|
||||
(open-input-file input)
|
||||
(lambda (in)
|
||||
(do ((x (read in) (read in))
|
||||
(y #f x)
|
||||
|
|
@ -44,11 +44,11 @@
|
|||
(input1 (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 input1)
|
||||
(name "read1:latin-1")
|
||||
(t (make-transcoder (latin-1-codec))))
|
||||
(run-r6rs-benchmark
|
||||
(name "read1:latin-1"))
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (read-from-file-benchmark (hide count input1) t))
|
||||
(lambda () (read-from-file-benchmark (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -55,10 +55,10 @@
|
|||
; The second phase creates the test problem, and tests to see
|
||||
; whether it is implied by the lemmas.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme cxr))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
|
|
@ -67,7 +67,7 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input))
|
||||
(name "sboyer"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda ()
|
||||
|
|
@ -786,3 +786,5 @@
|
|||
(if answer
|
||||
rewrite-count
|
||||
#f)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -2,12 +2,13 @@
|
|||
|
||||
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs unicode)
|
||||
(rnrs lists)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs)
|
||||
(rnrs mutable-strings))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme cxr)
|
||||
(scheme inexact)
|
||||
(scheme char)
|
||||
(scheme file))
|
||||
|
||||
(define (scheme-eval expr)
|
||||
(let ((code (scheme-comp expr scheme-global-environment)))
|
||||
|
|
@ -1049,10 +1050,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 "")
|
||||
(name "scheme"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (scheme-eval (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
;;; SIMPLEX -- Simplex algorithm.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme read)
|
||||
(scheme inexact))
|
||||
|
||||
(define (matrix-rows a) (vector-length a))
|
||||
(define (matrix-columns a) (vector-length (vector-ref a 0)))
|
||||
|
|
@ -39,11 +39,11 @@
|
|||
(set! kp (vector-ref l1 0))
|
||||
(set! bmax (matrix-ref a mm kp))
|
||||
(do ((k 1 (+ k 1))) ((>= k nl1))
|
||||
(if (flpositive?
|
||||
(if (positive?
|
||||
(if abs?
|
||||
(fl- (flabs (matrix-ref a mm (vector-ref l1 k)))
|
||||
(flabs bmax))
|
||||
(fl- (matrix-ref a mm (vector-ref l1 k)) bmax)))
|
||||
(- (abs (matrix-ref a mm (vector-ref l1 k)))
|
||||
(abs bmax))
|
||||
(- (matrix-ref a mm (vector-ref l1 k)) bmax)))
|
||||
(begin
|
||||
(set! kp (vector-ref l1 k))
|
||||
(set! bmax (matrix-ref a mm (vector-ref l1 k)))))))
|
||||
|
|
@ -53,59 +53,59 @@
|
|||
(flag? #f))
|
||||
(do ((i 0 (+ i 1))) ((= i m))
|
||||
(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
|
||||
(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))))
|
||||
(cond
|
||||
((fl<? q q1)
|
||||
((< q q1)
|
||||
(set! ip (vector-ref l2 i))
|
||||
(set! q1 q))
|
||||
((fl=? q q1)
|
||||
((= q q1)
|
||||
(let ((qp 0.0)
|
||||
(q0 0.0))
|
||||
(let loop ((k 1))
|
||||
(if (<= k n)
|
||||
(begin
|
||||
(set! qp
|
||||
(fl/ (fl- (matrix-ref a ip k))
|
||||
(/ (- (matrix-ref a ip k))
|
||||
(matrix-ref a ip kp)))
|
||||
(set! q0
|
||||
(fl/
|
||||
(fl-
|
||||
(/
|
||||
(-
|
||||
(matrix-ref a (vector-ref l2 i) k))
|
||||
(matrix-ref a (vector-ref l2 i) kp)))
|
||||
(if (fl=? q0 qp)
|
||||
(if (= q0 qp)
|
||||
(loop (+ k 1))))))
|
||||
(if (fl<? q0 qp)
|
||||
(if (< q0 qp)
|
||||
(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
|
||||
(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)))
|
||||
(set! ip (vector-ref l2 i))
|
||||
(set! flag? #t)))))))
|
||||
(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))))
|
||||
(if (not (= ii ip))
|
||||
(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)))
|
||||
(if (not (= kk kp))
|
||||
(matrix-set!
|
||||
a ii kk (fl- (matrix-ref a ii kk)
|
||||
(fl* (matrix-ref a ip kk)
|
||||
a ii kk (- (matrix-ref a ii kk)
|
||||
(* (matrix-ref a ip kk)
|
||||
(matrix-ref a ii kp)))))))))
|
||||
(do ((kk 0 (+ kk 1))) ((= kk (+ n 1)))
|
||||
(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)))
|
||||
(do ((k 0 (+ k 1))) ((= k n))
|
||||
(vector-set! l1 k (+ k 1))
|
||||
(vector-set! izrov k k))
|
||||
(do ((i 0 (+ i 1))) ((= i m))
|
||||
(if (flnegative? (matrix-ref a (+ i 1) 0))
|
||||
(if (negative? (matrix-ref a (+ i 1) 0))
|
||||
(complain))
|
||||
(vector-set! l2 i (+ i 1))
|
||||
(vector-set! iposv i (+ n i)))
|
||||
|
|
@ -113,20 +113,20 @@
|
|||
(if (positive? (+ m2 m3))
|
||||
(begin
|
||||
(do ((k 0 (+ k 1))) ((= k (+ n 1)))
|
||||
(do ((i (+ m1 1) (+ i 1)) (sum 0.0 (fl+ sum (matrix-ref a i k))))
|
||||
((> i m) (matrix-set! a (+ m 1) k (fl- sum)))))
|
||||
(do ((i (+ m1 1) (+ i 1)) (sum 0.0 (+ sum (matrix-ref a i k))))
|
||||
((> i m) (matrix-set! a (+ m 1) k (- sum)))))
|
||||
(let loop ()
|
||||
(simp1 (+ m 1) #f)
|
||||
(cond
|
||||
((fl<=? bmax *epsilon*)
|
||||
(cond ((fl<? (matrix-ref a (+ m 1) 0) (fl- *epsilon*))
|
||||
((<= bmax *epsilon*)
|
||||
(cond ((< (matrix-ref a (+ m 1) 0) (- *epsilon*))
|
||||
(set! pass2? #f))
|
||||
((fl<=? (matrix-ref a (+ m 1) 0) *epsilon*)
|
||||
((<= (matrix-ref a (+ m 1) 0) *epsilon*)
|
||||
(let loop ((ip1 m12))
|
||||
(if (<= ip1 m)
|
||||
(cond ((= (vector-ref iposv (- ip1 1)) (+ ip n -1))
|
||||
(simp1 ip1 #t)
|
||||
(cond ((flpositive? bmax)
|
||||
(cond ((positive? bmax)
|
||||
(set! ip ip1)
|
||||
(set! one? #t))
|
||||
(else
|
||||
|
|
@ -137,7 +137,7 @@
|
|||
(if (vector-ref l3 (- i (+ m1 1)))
|
||||
(do ((k 0 (+ k 1))) ((= k (+ n 1)))
|
||||
(matrix-set!
|
||||
a i k (fl- (matrix-ref a i k)))))))))
|
||||
a i k (- (matrix-ref a i k)))))))))
|
||||
(else
|
||||
(simp2)
|
||||
(if (zero? ip) (set! pass2? #f) (set! one? #t)))))
|
||||
|
|
@ -157,17 +157,17 @@
|
|||
(do ((is k (+ is 1))) ((>= is nl1))
|
||||
(vector-set! l1 is (vector-ref l1 (+ is 1))))
|
||||
(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)))
|
||||
(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))
|
||||
(vector-ref l3
|
||||
(- (vector-ref iposv (- ip 1)) (+ m1 n))))
|
||||
(vector-set! l3 (- (vector-ref iposv (- ip 1)) (+ m1 n)) #f)
|
||||
(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)))
|
||||
(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))))
|
||||
(vector-set! izrov (- kp 1) (vector-ref iposv (- ip 1)))
|
||||
(vector-set! iposv (- ip 1) t))
|
||||
|
|
@ -176,7 +176,7 @@
|
|||
(let loop ()
|
||||
(simp1 0 #f)
|
||||
(cond
|
||||
((flpositive? bmax)
|
||||
((positive? bmax)
|
||||
(simp2)
|
||||
(cond ((zero? ip) #t)
|
||||
(else (simp3 #f)
|
||||
|
|
@ -203,8 +203,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 "")
|
||||
(name "simplex"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (test (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -4,14 +4,11 @@
|
|||
;This file is compatible for the dialect other
|
||||
;(c) Dorai Sitaram, Rice U., 1991, 1994
|
||||
|
||||
(import
|
||||
(rnrs base)
|
||||
(rnrs unicode)
|
||||
(rnrs lists)
|
||||
(rnrs io simple)
|
||||
(rnrs files)
|
||||
(rnrs mutable-pairs)
|
||||
(rnrs mutable-strings))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file))
|
||||
|
||||
(define *op-sys* 'unix)
|
||||
|
||||
|
|
@ -2353,8 +2350,11 @@
|
|||
(s2 input2)
|
||||
(s1 input1)
|
||||
(name "slatex"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s3)
|
||||
count
|
||||
(lambda () (slatex.process-main-tex-file (hide count input1)))
|
||||
(lambda (result) #t))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
;;; STRING -- One of the Kernighan and Van Wyk benchmarks.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define div quotient)
|
||||
|
||||
(define s "abcdef")
|
||||
|
||||
|
|
@ -31,8 +33,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "string"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (my-try (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
;;; SUM -- Compute sum of integers from 0 to 10000
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (run n)
|
||||
(let loop ((i n) (sum 0))
|
||||
|
|
@ -16,8 +17,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "sum"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (run (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,14 +1,16 @@
|
|||
;;; SUM1 -- One of the Kernighan and Van Wyk benchmarks.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme inexact))
|
||||
|
||||
(define (sumport port sum-so-far)
|
||||
(let ((x (read port)))
|
||||
(if (eof-object? x)
|
||||
sum-so-far
|
||||
(sumport port (fl+ x sum-so-far)))))
|
||||
(sumport port (+ x sum-so-far)))))
|
||||
|
||||
(define (sum port)
|
||||
(sumport port 0.0))
|
||||
|
|
@ -23,9 +25,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 input1)
|
||||
(name "sum1"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(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")
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
;;; SUMFP -- Compute sum of integers from 0 to 10000 using floating point
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple)
|
||||
(rnrs arithmetic flonums))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (run n)
|
||||
(let loop ((i n) (sum 0.))
|
||||
(if (fl<? i 0.)
|
||||
(if (< i 0.)
|
||||
sum
|
||||
(loop (fl- i 1.) (fl+ i sum)))))
|
||||
(loop (- i 1.) (+ i sum)))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
|
|
@ -17,8 +17,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "sumfp"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (run (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -7,19 +7,19 @@
|
|||
;;; is produced, and the lines are then written to the output
|
||||
;;; in the reverse of the order in which they were read.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io ports)
|
||||
(rnrs io simple)
|
||||
(rnrs files))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme file))
|
||||
|
||||
(define (tail-r-aux port file-so-far)
|
||||
(let ((x (get-line port)))
|
||||
(let ((x (read-line port)))
|
||||
(if (eof-object? x)
|
||||
file-so-far
|
||||
(tail-r-aux port (cons x file-so-far)))))
|
||||
|
||||
(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 '())))
|
||||
|
||||
(define (go input output)
|
||||
|
|
@ -41,8 +41,10 @@
|
|||
(s2 input2)
|
||||
(s1 input1)
|
||||
(name "tail"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s3)
|
||||
count
|
||||
(lambda () (go (hide count input1) (hide count input2)))
|
||||
(lambda (result) #t))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
;;; TAK -- A vanilla version of the TAKeuchi function.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (tak x y z)
|
||||
(if (not (< y x))
|
||||
|
|
@ -21,9 +22,11 @@
|
|||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "tak"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3 ":" s4)
|
||||
count
|
||||
(lambda ()
|
||||
(tak (hide count input1) (hide count input2) (hide count input3)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
;;; TAKL -- The TAKeuchi function using lists as counters.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define (listn n)
|
||||
(if (= n 0)
|
||||
|
|
@ -36,9 +37,11 @@
|
|||
(s2 (number->string (length input2)))
|
||||
(s1 (number->string (length input1)))
|
||||
(name "takl"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3 ":" s4)
|
||||
count
|
||||
(lambda ()
|
||||
(mas (hide count input1) (hide count input2) (hide count input3)))
|
||||
(lambda (result) (equal? (length result) output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
;;; TRIANGL -- Board game benchmark.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
|
||||
(define *board*
|
||||
(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))
|
||||
(s1 (number->string input1))
|
||||
(name "triangl"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3)
|
||||
count
|
||||
(lambda () (test (hide count input1) (hide count input2)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
;;; WC -- One of the Kernighan and Van Wyk benchmarks.
|
||||
;;; Rewritten by Will Clinger into more idiomatic (and correct!) Scheme.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme char))
|
||||
|
||||
(define (wcport port)
|
||||
(define (loop nl nw nc inword?)
|
||||
|
|
@ -28,8 +30,10 @@
|
|||
(s2 (number->string count))
|
||||
(s1 input)
|
||||
(name "wc"))
|
||||
(run-r6rs-benchmark
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (go (hide count input)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
(include "src/common.sch")
|
||||
|
|
|
|||
Loading…
Reference in New Issue