import R6RS benchmarks from larceny (https://github.com/larceny/larceny)
This commit is contained in:
Sunrin SHIMURA (keen)
parent
592af901e2
commit
cd94f5b554
|
|
@ -0,0 +1,41 @@
|
|||
This directory contains a set of R6RS benchmarks. Some were
|
||||
originally collected by Richard Gabriel, while others were
|
||||
collected or written by Marc Feeley and Will Clinger.
|
||||
Abdulaziz Ghuloum converted about 50 of these benchmarks to
|
||||
R6RS libraries. R6RS libraries are non-portable by design,
|
||||
however, so Clinger rewrote the benchmarks as R6RS top-level
|
||||
programs and added a script for running the benchmarks on
|
||||
Unix systems. Clinger also added new benchmarks for R6RS.
|
||||
|
||||
Files and directories:
|
||||
|
||||
* bench : a shell script for running benchmarks
|
||||
* src : contains R6RS code for the benchmarks
|
||||
* inputs : contains inputs for the benchmarks
|
||||
* outputs : will hold the outputs of some benchmarks
|
||||
|
||||
For succinct instructions on running benchmarks, run the
|
||||
bench script without any arguments:
|
||||
|
||||
% ./bench
|
||||
|
||||
The bench script creates a /tmp/larcenous directory to hold
|
||||
the source code constructed for the benchmarks.
|
||||
|
||||
The bench script appends its results to files with names
|
||||
like results.Ikarus, results.Larceny, and so forth.
|
||||
|
||||
Will
|
||||
|
||||
================================================================
|
||||
|
||||
NOTE:
|
||||
The nbody, trav1, and trav2 benchmarks have been dropped because
|
||||
the depend upon a non-portable order of evaluation. The sumloop
|
||||
benchmark has been dropped because it was essentially the same
|
||||
as the sum benchmark. The boyer benchmark has been replaced by
|
||||
the nboyer and sboyer benchmarks, which are fundamentally better
|
||||
benchmarks, with fewer bugs, and scalable. The gcold benchmark
|
||||
has been dropped temporarily because its initialization phase is
|
||||
so long compared to the benchmark phase, and the R6RS provides
|
||||
no portable way to time those phases separately.
|
||||
|
|
@ -0,0 +1,425 @@
|
|||
#! /usr/bin/env bash
|
||||
|
||||
# For running R6RS benchmarks.
|
||||
#
|
||||
# Please report any errors or extensions to the author:
|
||||
#
|
||||
# William D Clinger (will@ccs.neu.edu)
|
||||
#
|
||||
# This script was loosely modelled after Marc Feeley's
|
||||
# script for benchmarking R5RS systems, with additional
|
||||
# contributions by Harvey Stein.
|
||||
#
|
||||
# Usage:
|
||||
#
|
||||
# % cd test/Benchmarking/R6RS
|
||||
# % ./bench <system> <benchmark>
|
||||
#
|
||||
# For the current list of systems and benchmarks, run this
|
||||
# script with no arguments.
|
||||
#
|
||||
# The benchmarks must be contained within a src subdirectory
|
||||
# of the directory in which this script is run.
|
||||
#
|
||||
# The inputs to the benchmarks must be contained within an
|
||||
# inputs subdirectory of the directory in which this script
|
||||
# is run.
|
||||
|
||||
OSNAME="`( uname )`"
|
||||
|
||||
# The following definitions are not in use, but using them
|
||||
# might improve the script.
|
||||
|
||||
HOME="`( pwd )`"
|
||||
SRC="${HOME}/src"
|
||||
INPUTS="${HOME}/inputs"
|
||||
|
||||
TEMP="/tmp/larcenous"
|
||||
|
||||
################################################################
|
||||
|
||||
GABRIEL_BENCHMARKS="browse deriv dderiv destruc diviter divrec puzzle triangl tak takl ntakl cpstak ctak"
|
||||
|
||||
NUM_BENCHMARKS="fib fibc fibfp sum sumfp fft mbrot mbrotZ nucleic pnpoly"
|
||||
|
||||
KVW_BENCHMARKS="ack array1 string sum1 cat cat2 cat3 tail wc"
|
||||
|
||||
IO_BENCHMARKS="read0 read1 read2 read3"
|
||||
|
||||
OTHER_BENCHMARKS="bibfreq bibfreq2 compiler conform dynamic earley graphs lattice matrix maze 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"
|
||||
|
||||
ALL_BENCHMARKS="$GABRIEL_BENCHMARKS $NUM_BENCHMARKS $KVW_BENCHMARKS $IO_BENCHMARKS $OTHER_BENCHMARKS $GC_BENCHMARKS $SYNTH_BENCHMARKS"
|
||||
|
||||
################################################################
|
||||
|
||||
NB_RUNS=1
|
||||
clean=true
|
||||
options=""
|
||||
|
||||
# On our Solaris machines, we can't install systems in
|
||||
# /usr/local, and some are in random places for historical
|
||||
# reasons.
|
||||
|
||||
setup ()
|
||||
{
|
||||
case ${OSNAME} in
|
||||
|
||||
"SunOS")
|
||||
|
||||
APPS="/proj/will/Apps"
|
||||
|
||||
;;
|
||||
|
||||
"Linux")
|
||||
|
||||
APPS="/usr/local"
|
||||
|
||||
IKARUS="${APPS}/bin/ikarus"
|
||||
HENCHMAN="/home/henchman/bin/larceny"
|
||||
;;
|
||||
|
||||
"Darwin")
|
||||
|
||||
IKARUS=${IKARUS:-"ikarus"}
|
||||
;;
|
||||
|
||||
esac
|
||||
|
||||
# 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"}
|
||||
|
||||
}
|
||||
|
||||
setup
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
|
||||
error ()
|
||||
{
|
||||
echo $1
|
||||
echo '
|
||||
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
|
||||
all for all of the above
|
||||
|
||||
<benchmark> is the name of the benchmark(s) to run:
|
||||
|
||||
all for all of the usual benchmarks
|
||||
fib for the fib benchmark
|
||||
"fib ack" for the fib and ack benchmarks
|
||||
|
||||
runs is the number of times to run each benchmark (default is 1).'
|
||||
|
||||
exit
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
|
||||
# FIXME: DANGER! DANGER! DANGER!
|
||||
# DON'T USE THIS UNTIL IT'S BEEN FIXED!
|
||||
|
||||
cleanup ()
|
||||
{
|
||||
if [ "$clean" = "true" ] ; then
|
||||
# It's true that technically speaking, we should be in the build
|
||||
# directory when this fcn is called. Thus, we should be able to
|
||||
# just do rm *. However, that's kind of dangerous, so instead,
|
||||
# we delete files newer than the mark file that evaluate () makes.
|
||||
|
||||
for x in * ; do
|
||||
if [ $x -nt clean_newer_than_me ] ; then
|
||||
rm $x
|
||||
fi
|
||||
done
|
||||
fi
|
||||
rm clean_newer_than_me
|
||||
}
|
||||
|
||||
evaluate ()
|
||||
{
|
||||
# echo > clean_newer_than_me
|
||||
sleep 1
|
||||
{
|
||||
echo
|
||||
echo Testing $1 under ${NAME}
|
||||
make_src_code $1
|
||||
echo Compiling...
|
||||
$COMP "${TEMP}/$1.${EXTENSION}"
|
||||
i=0
|
||||
while [ "$i" -lt "$NB_RUNS" ]
|
||||
do
|
||||
echo Running...
|
||||
$EXEC "${TEMP}/$1.${EXTENSIONCOMP}" "${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.
|
||||
|
||||
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 ()
|
||||
{
|
||||
:
|
||||
}
|
||||
|
||||
ikarus_exec ()
|
||||
{
|
||||
time "${IKARUS}" --r6rs-script "$1" < "$2"
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# Definitions specific to PLT Scheme
|
||||
|
||||
plt_comp ()
|
||||
{
|
||||
echo | time "${PLTR6RS}" --compile "$1"
|
||||
}
|
||||
|
||||
plt_exec ()
|
||||
{
|
||||
time "${PLTR6RS}" "$1" < "$2"
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# Definitions specific to Ypsilon
|
||||
|
||||
ypsilon_comp ()
|
||||
{
|
||||
:
|
||||
}
|
||||
|
||||
ypsilon_exec ()
|
||||
{
|
||||
time "${YPSILON}" "$1" < "$2"
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# Definitions specific to Mosh
|
||||
|
||||
mosh_comp ()
|
||||
{
|
||||
:
|
||||
}
|
||||
|
||||
mosh_exec ()
|
||||
{
|
||||
time "${MOSH}" "$1" < "$2"
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# Definitions specific to Petite Chez
|
||||
|
||||
petite_comp ()
|
||||
{
|
||||
:
|
||||
}
|
||||
|
||||
petite_exec ()
|
||||
{
|
||||
time "${PETITE}" --optimize-level 2 --program "$1" < "$2"
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
|
||||
## Arg processing...
|
||||
if [ "$#" -lt 2 ]; then
|
||||
error '>>> At least two command line arguments are needed'
|
||||
fi
|
||||
|
||||
|
||||
while [ $# -gt 2 ] ; do
|
||||
arg="$1"
|
||||
shift
|
||||
case $arg in
|
||||
-r) NB_RUNS=$1 ; shift ;;
|
||||
-c) clean=$1 ; shift ;;
|
||||
-o) options=$1 ; shift ;;
|
||||
*) error ">>> Unknown argument of $arg given." ;;
|
||||
esac
|
||||
done
|
||||
|
||||
if [ "$#" -ne 2 ]; then
|
||||
error '>>> Last two arguments must be <system> and <benchmark>'
|
||||
fi
|
||||
|
||||
case "$1" in
|
||||
all) systems="$ALL_SYSTEMS" ;;
|
||||
*) systems="$1" ;;
|
||||
esac
|
||||
|
||||
case "$2" in
|
||||
all) benchmarks="$ALL_BENCHMARKS" ;;
|
||||
gabriel) benchmarks="$GABRIEL_BENCHMARKS" ;;
|
||||
kvw) benchmarks="$KVW_BENCHMARKS" ;;
|
||||
other) benchmarks="$OTHER_BENCHMARKS" ;;
|
||||
awk) benchmarks="$AWK_BENCHMARKS" ;;
|
||||
c) benchmarks="$C_BENCHMARKS" ;;
|
||||
java) benchmarks="$JAVA_BENCHMARKS" ;;
|
||||
*) benchmarks="$2" ;;
|
||||
esac
|
||||
|
||||
## Run each benchmark under each system...
|
||||
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
|
||||
COMPOPTS=""
|
||||
EXTENSION="sch"
|
||||
EXTENSIONCOMP="sch"
|
||||
COMPCOMMANDS=""
|
||||
EXECCOMMANDS=""
|
||||
;;
|
||||
|
||||
plt) NAME='PLT'
|
||||
COMP=plt_comp
|
||||
EXEC=plt_exec
|
||||
COMPOPTS=""
|
||||
EXTENSION="sch"
|
||||
EXTENSIONCOMP="sch"
|
||||
COMPCOMMANDS=""
|
||||
EXECCOMMANDS=""
|
||||
;;
|
||||
|
||||
ypsilon) NAME='Ypsilon' # copied from Ikarus' settings...
|
||||
COMP=ypsilon_comp
|
||||
EXEC=ypsilon_exec
|
||||
COMPOPTS=""
|
||||
EXTENSION="sch"
|
||||
EXTENSIONCOMP="sch"
|
||||
COMPCOMMANDS=""
|
||||
EXECCOMMANDS=""
|
||||
;;
|
||||
|
||||
mosh) NAME='Mosh'
|
||||
COMP=mosh_comp
|
||||
EXEC=mosh_exec
|
||||
COMPOPTS=""
|
||||
EXTENSION="sch"
|
||||
EXTENSIONCOMP="sch"
|
||||
COMPCOMMANDS=""
|
||||
EXECCOMMANDS=""
|
||||
;;
|
||||
|
||||
petite) NAME='Petite'
|
||||
COMP=petite_comp
|
||||
EXEC=petite_exec
|
||||
COMPOPTS=""
|
||||
EXTENSION="sch"
|
||||
EXTENSIONCOMP="sch"
|
||||
COMPCOMMANDS=""
|
||||
EXECCOMMANDS=""
|
||||
;;
|
||||
|
||||
esac
|
||||
|
||||
{
|
||||
echo
|
||||
echo '****************************'
|
||||
echo Benchmarking ${NAME} on `date` under `uname -a`
|
||||
} >> results.${NAME}
|
||||
|
||||
mkdir "${TEMP}"
|
||||
|
||||
for program in $benchmarks ; do
|
||||
evaluate $program
|
||||
done
|
||||
done
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,4 @@
|
|||
1
|
||||
3
|
||||
12
|
||||
32765
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
100
|
||||
1000000
|
||||
1000000
|
||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
|
|
@ -0,0 +1,4 @@
|
|||
1
|
||||
"inputs/bib"
|
||||
((the . 63922) (and . 51696) (of . 34615) (to . 13562) (that . 12913)
|
||||
(in . 12666) (he . 10420) (shall . 9838) (unto . 8997) (for . 8971))
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
1
|
||||
"inputs/bib"
|
||||
((the . 63922) (and . 51696) (of . 34615) (to . 13562) (that . 12913)
|
||||
(in . 12666) (he . 10420) (shall . 9838) (unto . 8997) (for . 8971))
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
1000
|
||||
((*a ?b *b ?b a *a a *b *a)
|
||||
(*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)
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
2
|
||||
1000 ; number of random stress tests
|
||||
100 ; twice average length of random test string
|
||||
0 ; number of tests that should fail
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
25
|
||||
"inputs/bib"
|
||||
"outputs/cat.output"
|
||||
ignored
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
25
|
||||
"inputs/bib"
|
||||
"outputs/cat2.output"
|
||||
ignored
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
10
|
||||
"inputs/bib16"
|
||||
"outputs/cat3.output"
|
||||
ignored
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,555 @@
|
|||
1000
|
||||
|
||||
(begin
|
||||
(declare (standard-bindings) (fixnum) (not safe) (block))
|
||||
(define (fib n)
|
||||
(if (< n 2)
|
||||
n
|
||||
(+ (fib (- n 1))
|
||||
(fib (- n 2)))))
|
||||
|
||||
(define (tak x y z)
|
||||
(if (not (< y x))
|
||||
z
|
||||
(tak (tak (- x 1) y z)
|
||||
(tak (- y 1) z x)
|
||||
(tak (- z 1) x y))))
|
||||
|
||||
(define (ack m n)
|
||||
(cond ((= m 0) (+ n 1))
|
||||
((= n 0) (ack (- m 1) 1))
|
||||
(else (ack (- m 1) (ack m (- n 1))))))
|
||||
|
||||
(define (create-x n)
|
||||
(define result (make-vector n))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((>= i n) result)
|
||||
(vector-set! result i i)))
|
||||
|
||||
(define (create-y x)
|
||||
(let* ((n (vector-length x))
|
||||
(result (make-vector n)))
|
||||
(do ((i (- n 1) (- i 1)))
|
||||
((< i 0) result)
|
||||
(vector-set! result i (vector-ref x i)))))
|
||||
|
||||
(define (my-try n)
|
||||
(vector-length (create-y (create-x n))))
|
||||
|
||||
(define (go n)
|
||||
(let loop ((repeat 100)
|
||||
(result 0))
|
||||
(if (> repeat 0)
|
||||
(loop (- repeat 1) (my-try n))
|
||||
result)))
|
||||
|
||||
(+ (fib 20)
|
||||
(tak 18 12 6)
|
||||
(ack 3 9)
|
||||
(go 200000)))
|
||||
|
||||
m68000
|
||||
|
||||
asm
|
||||
|
||||
|
||||
; The expected output:
|
||||
|
||||
(
|
||||
"|------------------------------------------------------"
|
||||
"| #[primitive #!program] ="
|
||||
"L1:"
|
||||
" cmpw #1,d0"
|
||||
" beq L1000"
|
||||
" TRAP1(9,0)"
|
||||
" LBL_PTR(L1)"
|
||||
"L1000:"
|
||||
" MOVE_PROC(1,a1)"
|
||||
" movl a1,GLOB(fib)"
|
||||
" MOVE_PROC(2,a1)"
|
||||
" movl a1,GLOB(tak)"
|
||||
" MOVE_PROC(3,a1)"
|
||||
" movl a1,GLOB(ack)"
|
||||
" MOVE_PROC(4,a1)"
|
||||
" movl a1,GLOB(create-x)"
|
||||
" MOVE_PROC(5,a1)"
|
||||
" movl a1,GLOB(create-y)"
|
||||
" MOVE_PROC(6,a1)"
|
||||
" movl a1,GLOB(my-try)"
|
||||
" MOVE_PROC(7,a1)"
|
||||
" movl a1,GLOB(go)"
|
||||
" movl a0,sp@-"
|
||||
" movl #160,d1"
|
||||
" lea L2,a0"
|
||||
" dbra d5,L1001"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1001"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1002:"
|
||||
"L1001:"
|
||||
" JMP_PROC(1,10)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L2:"
|
||||
" movl d1,sp@-"
|
||||
" moveq #48,d3"
|
||||
" moveq #96,d2"
|
||||
" movl #144,d1"
|
||||
" lea L3,a0"
|
||||
" JMP_PROC(2,14)"
|
||||
" RETURN(L1,2,1)"
|
||||
"L3:"
|
||||
" movl d1,sp@-"
|
||||
" moveq #72,d2"
|
||||
" moveq #24,d1"
|
||||
" lea L4,a0"
|
||||
" JMP_PROC(3,10)"
|
||||
" RETURN(L1,3,1)"
|
||||
"L4:"
|
||||
" movl d1,sp@-"
|
||||
" movl #1600000,d1"
|
||||
" lea L5,a0"
|
||||
" JMP_PROC(7,10)"
|
||||
" RETURN(L1,4,1)"
|
||||
"L5:"
|
||||
" dbra d5,L1003"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1003"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,4,1)"
|
||||
"L1004:"
|
||||
"L1003:"
|
||||
"L6:"
|
||||
" addl sp@(8),d1"
|
||||
" addl sp@(4),d1"
|
||||
" addl sp@+,d1"
|
||||
" addql #8,sp"
|
||||
" rts"
|
||||
"L0:"
|
||||
"|------------------------------------------------------"
|
||||
"| #[primitive fib] ="
|
||||
"L1:"
|
||||
" bmi L1000"
|
||||
" TRAP1(9,1)"
|
||||
" LBL_PTR(L1)"
|
||||
"L1000:"
|
||||
" moveq #16,d0"
|
||||
" cmpl d1,d0"
|
||||
" ble L3"
|
||||
" bra L4"
|
||||
" RETURN(L1,2,1)"
|
||||
"L2:"
|
||||
" movl d1,sp@-"
|
||||
" movl sp@(4),d1"
|
||||
" moveq #-16,d0"
|
||||
" addl d0,d1"
|
||||
" lea L5,a0"
|
||||
" moveq #16,d0"
|
||||
" cmpl d1,d0"
|
||||
" bgt L4"
|
||||
"L3:"
|
||||
" movl a0,sp@-"
|
||||
" movl d1,sp@-"
|
||||
" subql #8,d1"
|
||||
" lea L2,a0"
|
||||
" dbra d5,L1001"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1001"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,2,1)"
|
||||
"L1002:"
|
||||
"L1001:"
|
||||
" moveq #16,d0"
|
||||
" cmpl d1,d0"
|
||||
" ble L3"
|
||||
"L4:"
|
||||
" jmp a0@"
|
||||
" RETURN(L1,3,1)"
|
||||
"L5:"
|
||||
" addl sp@+,d1"
|
||||
" dbra d5,L1003"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1003"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,2,1)"
|
||||
"L1004:"
|
||||
"L1003:"
|
||||
" addql #4,sp"
|
||||
" rts"
|
||||
"L0:"
|
||||
"|------------------------------------------------------"
|
||||
"| #[primitive tak] ="
|
||||
"L1:"
|
||||
" cmpw #4,d0"
|
||||
" beq L1000"
|
||||
" TRAP1(9,3)"
|
||||
" LBL_PTR(L1)"
|
||||
"L1000:"
|
||||
" cmpl d1,d2"
|
||||
" bge L4"
|
||||
" bra L3"
|
||||
" RETURN(L1,6,1)"
|
||||
"L2:"
|
||||
" movl d1,d3"
|
||||
" movl sp@(20),a0"
|
||||
" movl sp@+,d2"
|
||||
" movl sp@+,d1"
|
||||
" dbra d5,L1001"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1001"
|
||||
" movl a0,sp@(12)"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,4,1)"
|
||||
"L1002:"
|
||||
" movl sp@(12),a0"
|
||||
"L1001:"
|
||||
" cmpl d1,d2"
|
||||
" lea sp@(16),sp"
|
||||
" bge L4"
|
||||
"L3:"
|
||||
" movl a0,sp@-"
|
||||
" movl d1,sp@-"
|
||||
" movl d2,sp@-"
|
||||
" movl d3,sp@-"
|
||||
" subql #8,d1"
|
||||
" lea L5,a0"
|
||||
" dbra d5,L1003"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1003"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,4,1)"
|
||||
"L1004:"
|
||||
"L1003:"
|
||||
" cmpl d1,d2"
|
||||
" blt L3"
|
||||
"L4:"
|
||||
" movl d3,d1"
|
||||
" jmp a0@"
|
||||
" RETURN(L1,4,1)"
|
||||
"L5:"
|
||||
" movl d1,sp@-"
|
||||
" movl sp@(12),d3"
|
||||
" movl sp@(4),d2"
|
||||
" movl sp@(8),d1"
|
||||
" subql #8,d1"
|
||||
" lea L6,a0"
|
||||
" cmpl d1,d2"
|
||||
" bge L4"
|
||||
" bra L3"
|
||||
" RETURN(L1,5,1)"
|
||||
"L6:"
|
||||
" movl d1,sp@-"
|
||||
" movl sp@(12),d3"
|
||||
" movl sp@(16),d2"
|
||||
" movl sp@(8),d1"
|
||||
" subql #8,d1"
|
||||
" lea L2,a0"
|
||||
" cmpl d1,d2"
|
||||
" bge L4"
|
||||
" bra L3"
|
||||
"L0:"
|
||||
"|------------------------------------------------------"
|
||||
"| #[primitive ack] ="
|
||||
"L1:"
|
||||
" beq L1000"
|
||||
" TRAP1(9,2)"
|
||||
" LBL_PTR(L1)"
|
||||
"L1000:"
|
||||
" movl d1,d0"
|
||||
" bne L3"
|
||||
" bra L5"
|
||||
" RETURN(L1,2,1)"
|
||||
"L2:"
|
||||
" movl d1,d2"
|
||||
" movl sp@+,d1"
|
||||
" subql #8,d1"
|
||||
" movl sp@+,a0"
|
||||
" dbra d5,L1001"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1001"
|
||||
" movl a0,sp@-"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1002:"
|
||||
" movl sp@+,a0"
|
||||
"L1001:"
|
||||
" movl d1,d0"
|
||||
" beq L5"
|
||||
"L3:"
|
||||
" movl d2,d0"
|
||||
" bne L6"
|
||||
"L4:"
|
||||
" subql #8,d1"
|
||||
" moveq #8,d2"
|
||||
" dbra d5,L1003"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1003"
|
||||
" movl a0,sp@-"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1004:"
|
||||
" movl sp@+,a0"
|
||||
"L1003:"
|
||||
" movl d1,d0"
|
||||
" bne L3"
|
||||
"L5:"
|
||||
" movl d2,d1"
|
||||
" addql #8,d1"
|
||||
" jmp a0@"
|
||||
"L6:"
|
||||
" movl a0,sp@-"
|
||||
" movl d1,sp@-"
|
||||
" movl d2,d1"
|
||||
" subql #8,d1"
|
||||
" movl d1,d2"
|
||||
" movl sp@,d1"
|
||||
" lea L2,a0"
|
||||
" dbra d5,L1005"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1005"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,2,1)"
|
||||
"L1006:"
|
||||
"L1005:"
|
||||
" movl d1,d0"
|
||||
" bne L3"
|
||||
" bra L5"
|
||||
"L0:"
|
||||
"|------------------------------------------------------"
|
||||
"| #[primitive create-x] ="
|
||||
"L1:"
|
||||
" bmi L1000"
|
||||
" TRAP1(9,1)"
|
||||
" LBL_PTR(L1)"
|
||||
"L1000:"
|
||||
" movl a0,sp@-"
|
||||
" movl d1,sp@-"
|
||||
" lea L2,a0"
|
||||
" dbra d5,L1001"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1001"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,2,1)"
|
||||
"L1002:"
|
||||
"L1001:"
|
||||
" moveq #-1,d0"
|
||||
" JMP_PRIM(make-vector,0)"
|
||||
" RETURN(L1,2,1)"
|
||||
"L2:"
|
||||
" movl d1,d2"
|
||||
" movl sp@+,d1"
|
||||
" moveq #0,d3"
|
||||
" movl sp@+,a0"
|
||||
" dbra d5,L1003"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1003"
|
||||
" movl a0,sp@-"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1004:"
|
||||
" movl sp@+,a0"
|
||||
"L1003:"
|
||||
" cmpl d1,d3"
|
||||
" bge L4"
|
||||
"L3:"
|
||||
" movl d3,d0"
|
||||
" asrl #1,d0"
|
||||
" movl d2,a1"
|
||||
" movl d3,a1@(1,d0:l)"
|
||||
" addql #8,d3"
|
||||
" dbra d5,L1005"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1005"
|
||||
" movl a0,sp@-"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1006:"
|
||||
" movl sp@+,a0"
|
||||
"L1005:"
|
||||
" cmpl d1,d3"
|
||||
" blt L3"
|
||||
"L4:"
|
||||
" movl d2,d1"
|
||||
" jmp a0@"
|
||||
"L0:"
|
||||
"|------------------------------------------------------"
|
||||
"| #[primitive create-y] ="
|
||||
"L1:"
|
||||
" bmi L1000"
|
||||
" TRAP1(9,1)"
|
||||
" LBL_PTR(L1)"
|
||||
"L1000:"
|
||||
" movl d1,a1"
|
||||
" movl a1@(-3),d2"
|
||||
" lsrl #7,d2"
|
||||
" movl a0,sp@-"
|
||||
" movl d1,sp@-"
|
||||
" movl d2,sp@-"
|
||||
" movl d2,d1"
|
||||
" lea L2,a0"
|
||||
" dbra d5,L1001"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1001"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,3,1)"
|
||||
"L1002:"
|
||||
"L1001:"
|
||||
" moveq #-1,d0"
|
||||
" JMP_PRIM(make-vector,0)"
|
||||
" RETURN(L1,3,1)"
|
||||
"L2:"
|
||||
" movl sp@+,d2"
|
||||
" subql #8,d2"
|
||||
" movl d2,d3"
|
||||
" movl d1,d2"
|
||||
" movl sp@+,d1"
|
||||
" movl sp@+,a0"
|
||||
" dbra d5,L1003"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1003"
|
||||
" movl a0,sp@-"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1004:"
|
||||
" movl sp@+,a0"
|
||||
"L1003:"
|
||||
" movl d3,d0"
|
||||
" blt L4"
|
||||
"L3:"
|
||||
" movl d3,d0"
|
||||
" asrl #1,d0"
|
||||
" movl d1,a1"
|
||||
" movl a1@(1,d0:l),d4"
|
||||
" movl d3,d0"
|
||||
" asrl #1,d0"
|
||||
" movl d2,a1"
|
||||
" movl d4,a1@(1,d0:l)"
|
||||
" subql #8,d3"
|
||||
" dbra d5,L1005"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1005"
|
||||
" movl a0,sp@-"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1006:"
|
||||
" movl sp@+,a0"
|
||||
"L1005:"
|
||||
" movl d3,d0"
|
||||
" bge L3"
|
||||
"L4:"
|
||||
" movl d2,d1"
|
||||
" jmp a0@"
|
||||
"L0:"
|
||||
"|------------------------------------------------------"
|
||||
"| #[primitive my-try] ="
|
||||
"L1:"
|
||||
" bmi L1000"
|
||||
" TRAP1(9,1)"
|
||||
" LBL_PTR(L1)"
|
||||
"L1000:"
|
||||
" movl a0,sp@-"
|
||||
" lea L2,a0"
|
||||
" dbra d5,L1001"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1001"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1002:"
|
||||
"L1001:"
|
||||
" JMP_PROC(4,10)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L2:"
|
||||
" lea L3,a0"
|
||||
" JMP_PROC(5,10)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L3:"
|
||||
" movl d1,a1"
|
||||
" movl a1@(-3),d1"
|
||||
" lsrl #7,d1"
|
||||
" dbra d5,L1003"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1003"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1004:"
|
||||
"L1003:"
|
||||
" rts"
|
||||
"L0:"
|
||||
"|------------------------------------------------------"
|
||||
"| #[primitive go] ="
|
||||
"L1:"
|
||||
" bmi L1000"
|
||||
" TRAP1(9,1)"
|
||||
" LBL_PTR(L1)"
|
||||
"L1000:"
|
||||
" moveq #0,d3"
|
||||
" movl #800,d2"
|
||||
" dbra d5,L1001"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1001"
|
||||
" movl a0,sp@-"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1002:"
|
||||
" movl sp@+,a0"
|
||||
"L1001:"
|
||||
" movl d2,d0"
|
||||
" ble L4"
|
||||
" bra L3"
|
||||
" RETURN(L1,3,1)"
|
||||
"L2:"
|
||||
" movl d1,d3"
|
||||
" movl sp@+,d1"
|
||||
" subql #8,d1"
|
||||
" movl d1,d2"
|
||||
" movl sp@+,d1"
|
||||
" movl sp@+,a0"
|
||||
" dbra d5,L1003"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1003"
|
||||
" movl a0,sp@-"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,1,1)"
|
||||
"L1004:"
|
||||
" movl sp@+,a0"
|
||||
"L1003:"
|
||||
" movl d2,d0"
|
||||
" ble L4"
|
||||
"L3:"
|
||||
" movl a0,sp@-"
|
||||
" movl d1,sp@-"
|
||||
" movl d2,sp@-"
|
||||
" lea L2,a0"
|
||||
" dbra d5,L1005"
|
||||
" moveq #9,d5"
|
||||
" cmpl a5@,sp"
|
||||
" bcc L1005"
|
||||
" TRAP2(24)"
|
||||
" RETURN(L1,3,1)"
|
||||
"L1006:"
|
||||
"L1005:"
|
||||
" JMP_PROC(6,10)"
|
||||
"L4:"
|
||||
" movl d3,d1"
|
||||
" jmp a0@"
|
||||
"L0:"
|
||||
"")
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
200
|
||||
(a b "c" "d")
|
||||
|
||||
("(((b v d) ^ a) v c)"
|
||||
"(c ^ d)"
|
||||
"(b v (a ^ d))"
|
||||
"((a v d) ^ b)"
|
||||
"(b v d)"
|
||||
"(b ^ (a v c))"
|
||||
"(a v (c ^ d))"
|
||||
"((b v d) ^ a)"
|
||||
"(c v (a v d))"
|
||||
"(a v c)"
|
||||
"(d v (b ^ (a v c)))"
|
||||
"(d ^ (a v c))"
|
||||
"((a ^ d) v c)"
|
||||
"((a ^ b) v d)"
|
||||
"(((a v d) ^ b) v (a ^ d))"
|
||||
"(b ^ d)"
|
||||
"(b v (a v d))"
|
||||
"(a ^ c)"
|
||||
"(b ^ (c v d))"
|
||||
"(a ^ b)"
|
||||
"(a v b)"
|
||||
"((a ^ d) ^ b)"
|
||||
"(a ^ d)"
|
||||
"(a v d)"
|
||||
"d"
|
||||
"(c v d)"
|
||||
"a"
|
||||
"b"
|
||||
"c"
|
||||
"any"
|
||||
"none")
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
5
|
||||
32
|
||||
16
|
||||
8
|
||||
9
|
||||
|
||||
|
||||
; The old inputs and output for cpstak were:
|
||||
|
||||
1700
|
||||
18
|
||||
12
|
||||
6
|
||||
7
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
1
|
||||
32
|
||||
16
|
||||
8
|
||||
9
|
||||
|
||||
|
||||
; The old inputs and output for ctak were:
|
||||
|
||||
160
|
||||
18
|
||||
12
|
||||
6
|
||||
7
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
10000000
|
||||
|
||||
(+ (* 3 x x) (* a x x) (* b x) 5)
|
||||
|
||||
(+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x)))
|
||||
(* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x)))
|
||||
(* (* b x) (+ (/ 0 b) (/ 1 x)))
|
||||
0)
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
10000000
|
||||
|
||||
(+ (* 3 x x) (* a x x) (* b x) 5)
|
||||
|
||||
(+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x)))
|
||||
(* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x)))
|
||||
(* (* b x) (+ (/ 0 b) (/ 1 x)))
|
||||
0)
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
1000
|
||||
600
|
||||
50
|
||||
|
||||
((1 1 2)
|
||||
(1 1 1)
|
||||
(1 1 1 2)
|
||||
(1 1 1 1)
|
||||
(1 1 1 1 2)
|
||||
(1 1 1 1 2)
|
||||
(1 1 1 1 2)
|
||||
(1 1 1 1 2)
|
||||
(1 1 1 1 2)
|
||||
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 3))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
1000000
|
||||
1000
|
||||
500
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
1000000
|
||||
1000
|
||||
500
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,3 @@
|
|||
200
|
||||
"inputs/dynamic.data"
|
||||
((218 . 455) (6 . 1892) (2204 . 446))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
1
|
||||
15
|
||||
2674440
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
100
|
||||
100
|
||||
8
|
||||
1000
|
||||
2000
|
||||
5000
|
||||
#t
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
50
|
||||
65536
|
||||
0.0
|
||||
0.0
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
1
|
||||
40
|
||||
102334155
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
10
|
||||
30
|
||||
832040
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
10
|
||||
35.0
|
||||
9227465.0
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
1
|
||||
20
|
||||
0
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
1
|
||||
7
|
||||
213829
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
25 ; number of iterations
|
||||
100000 ; number of items added to stress the eq? hashtable
|
||||
100000 ; number of items added to stress the eqv? hashtable
|
||||
102005 ; number of items in table at end of benchmark
|
||||
; (always 2005 plus number of items added to stress the table)
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
10
|
||||
44
|
||||
120549
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
1
|
||||
0
|
||||
#x10ffff
|
||||
ignored
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
1000
|
||||
5
|
||||
5
|
||||
|
||||
(((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
|
||||
(1 1 -1 -1 -1) (1 -1 1 -1 -1) (1 -1 -1 1 1))
|
||||
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
|
||||
(1 1 -1 1 -1) (1 -1 1 -1 -1) (1 -1 -1 1 1))
|
||||
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
|
||||
(1 1 -1 1 -1) (1 -1 1 -1 1) (1 -1 -1 1 1))
|
||||
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
|
||||
(1 1 -1 1 1) (1 -1 1 1 -1) (1 -1 -1 -1 1))
|
||||
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
|
||||
(1 1 -1 1 1) (1 -1 1 1 1) (1 -1 -1 -1 -1)))))
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
5000
|
||||
20
|
||||
7
|
||||
(#\ #\ #\ #\_ #\ #\ #\ #\_ #\ #\ #\ #\_ #\newline
|
||||
#\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\newline
|
||||
#\/ #\ #\\ #\ #\ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\newline
|
||||
#\\ #\ #\ #\ #\\ #\ #\/ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
|
||||
#\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
|
||||
#\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\/ #\newline
|
||||
#\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline
|
||||
#\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\newline
|
||||
#\/ #\ #\\ #\ #\/ #\. #\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\newline
|
||||
#\\ #\_ #\/ #\ #\\ #\ #\/ #\. #\ #\_ #\ #\. #\\ #\ #\/ #\newline
|
||||
#\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\ #\\ #\ #\ #\ #\\ #\newline
|
||||
#\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
|
||||
#\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline
|
||||
#\\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\_ #\/ #\newline
|
||||
#\/ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\. #\\ #\newline
|
||||
#\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
|
||||
#\/ #\ #\\ #\_ #\ #\ #\\ #\ #\/ #\. #\\ #\ #\ #\. #\\ #\newline
|
||||
#\\ #\ #\/ #\. #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\ #\/ #\newline
|
||||
#\/ #\ #\ #\ #\ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\newline
|
||||
#\\ #\ #\/ #\. #\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\ #\/ #\newline
|
||||
#\/ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\newline
|
||||
#\\ #\_ #\ #\ #\\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline
|
||||
#\/ #\ #\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\ #\\ #\newline
|
||||
#\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline
|
||||
#\/ #\ #\\ #\ #\/ #\ #\ #\_ #\ #\. #\ #\_ #\ #\ #\\ #\newline
|
||||
#\\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\ #\ #\\ #\_ #\/ #\newline
|
||||
#\/ #\ #\ #\_ #\ #\ #\\ #\ #\ #\ #\\ #\_ #\/ #\ #\\ #\newline
|
||||
#\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\_ #\/ #\ #\ #\_ #\/ #\newline
|
||||
#\/ #\ #\\ #\ #\ #\. #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\newline
|
||||
#\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline
|
||||
#\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\. #\ #\ #\ #\ #\\ #\newline
|
||||
#\\ #\ #\ #\ #\ #\ #\ #\. #\ #\ #\/ #\. #\\ #\_ #\/ #\newline
|
||||
#\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
|
||||
#\\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\ #\/ #\newline
|
||||
#\/ #\ #\ #\ #\/ #\ #\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\newline
|
||||
#\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\_ #\/ #\newline
|
||||
#\/ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
|
||||
#\\ #\ #\ #\ #\ #\_ #\/ #\. #\ #\ #\/ #\. #\ #\_ #\/ #\newline
|
||||
#\/ #\ #\\ #\ #\/ #\. #\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
|
||||
#\\ #\_ #\/ #\. #\ #\_ #\/ #\. #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline
|
||||
#\/ #\ #\ #\_ #\ #\. #\\ #\_ #\ #\. #\ #\_ #\ #\. #\\ #\newline
|
||||
#\\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\newline)
|
||||
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
5000
|
||||
11
|
||||
11
|
||||
((_ * _ _ _ _ _ _ _ _ _)
|
||||
(_ * * * * * * * _ * *)
|
||||
(_ _ _ * _ _ _ * _ _ _)
|
||||
(_ * _ * _ * _ * _ * _)
|
||||
(_ * _ _ _ * _ * _ * _)
|
||||
(* * _ * * * * * _ * _)
|
||||
(_ * _ _ _ _ _ _ _ * _)
|
||||
(_ * _ * _ * * * * * *)
|
||||
(_ _ _ * _ _ _ _ _ _ _)
|
||||
(_ * * * * * * * _ * *)
|
||||
(_ * _ _ _ _ _ _ _ _ _))
|
||||
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
1000
|
||||
75
|
||||
5
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
1000
|
||||
75
|
||||
5
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
; The traditional parameters for this benchmark are 10:9:2:1,
|
||||
; but that's too small for modern computers.
|
||||
;
|
||||
; The new parameters for this benchmark are 20:10:2:1.
|
||||
; M: N:K:L
|
||||
;
|
||||
; N=10 means the benchmark starts by generating a list of all
|
||||
; 10! = 3628800 permutations of the first 10 integers, allocating
|
||||
; 13492889 pairs (a little over 100 megabytes on 32-bit machines
|
||||
; with two-word pairs), all of which goes into the generated list.
|
||||
; (That is, the first phase of the benchmark generates absolutely
|
||||
; no garbage.) This represents a savings of about 63% over the
|
||||
; storage that would be required by an unshared list of permuations.
|
||||
; The generated permutations are in order of a gray code that bears
|
||||
; no obvious relationship to a lexicographic order.
|
||||
;
|
||||
; Then M*(K-L) = 20*(2-1) = 20 more such lists are allocated.
|
||||
;
|
||||
; The live storage peaks at K=2 times the storage occupied by a
|
||||
; single list of all N! permutations.
|
||||
;
|
||||
; At the end of each of the M=20 iterations, the oldest L/K = 1/2
|
||||
; of the peak storage becomes garbage. Object lifetimes (measured
|
||||
; in bytes or pairs allocated) are distributed uniformly between
|
||||
; L/K times the peak storage and the peak storage itself.
|
||||
|
||||
20 ; M (number of iterations)
|
||||
10 ; N (length of each permutation)
|
||||
2 ; K (size of queue)
|
||||
1 ; L (number of old copies removed when queue is filled)
|
||||
|
||||
; Note: the result below is ignored, since it can be
|
||||
; computed from N above.
|
||||
|
||||
16329600 ; result (/ (* N (+ N 1) (factorial N)) 2)
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
1
|
||||
4
|
||||
16445406 ; if the input is 4
|
||||
51507739 ; if the input is 5
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
5
|
||||
|
||||
; Get NormalizationTest.txt from http://www.unicode.org/
|
||||
|
||||
"inputs/NormalizationTest.txt"
|
||||
|
||||
; Number of normalization tests for Unicode 5.0.0
|
||||
|
||||
351980
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
10
|
||||
13
|
||||
73712
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
2
|
||||
|
||||
(32 31 30 29 28 27 26 25 24 23 22 21
|
||||
20 19 18 17 16 15 14 13 12 11
|
||||
10 9 8 7 6 5 4 3 2 1)
|
||||
|
||||
( 16 15 14 13 12 11
|
||||
10 9 8 7 6 5 4 3 2 1)
|
||||
|
||||
(8 7 6 5 4 3 2 1)
|
||||
|
||||
9
|
||||
|
||||
|
||||
; The old inputs and output for takl were:
|
||||
|
||||
600
|
||||
(a list of 18 elements)
|
||||
(a list of 12 elements)
|
||||
(a list of 6 elements)
|
||||
7
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
50
|
||||
()
|
||||
33.797594890762724
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
5
|
||||
23
|
||||
5731580
|
||||
|
||||
|
||||
; the following seems to take too much memory
|
||||
|
||||
5
|
||||
24
|
||||
14490245
|
||||
|
|
@ -0,0 +1,772 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; File: nboyer.sch
|
||||
; Description: The Boyer benchmark
|
||||
; Author: Bob Boyer
|
||||
; Created: 5-Apr-85
|
||||
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
|
||||
; 22-Jul-87 (Will Clinger)
|
||||
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
|
||||
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
|
||||
; rewrote to eliminate property lists, and added
|
||||
; a scaling parameter suggested by Bob Boyer)
|
||||
; 19-Mar-99 (Will Clinger -- cleaned up comments)
|
||||
; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
|
||||
; Language: Scheme
|
||||
; Status: Public Domain
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; NBOYER -- Logic programming benchmark, originally written by Bob Boyer.
|
||||
;;; Fairly CONS intensive.
|
||||
|
||||
; Note: The version of this benchmark that appears in Dick Gabriel's book
|
||||
; contained several bugs that are corrected here. These bugs are discussed
|
||||
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
|
||||
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
|
||||
;
|
||||
; The benchmark now returns a boolean result.
|
||||
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
|
||||
; in Common Lisp)
|
||||
; ONE-WAY-UNIFY1 now treats numbers correctly
|
||||
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
|
||||
; Rule 19 has been corrected (this rule was not touched by the original
|
||||
; benchmark, but is used by this version)
|
||||
; Rules 84 and 101 have been corrected (but these rules are never touched
|
||||
; by the benchmark)
|
||||
;
|
||||
; According to Baker, these bug fixes make the benchmark 10-25% slower.
|
||||
; Please do not compare the timings from this benchmark against those of
|
||||
; the original benchmark.
|
||||
;
|
||||
; This version of the benchmark also prints the number of rewrites as a sanity
|
||||
; check, because it is too easy for a buggy version to return the correct
|
||||
; boolean result. The correct number of rewrites is
|
||||
;
|
||||
; n rewrites peak live storage (approximate, in bytes)
|
||||
; 0 95024 520,000
|
||||
; 1 591777 2,085,000
|
||||
; 2 1813975 5,175,000
|
||||
; 3 5375678
|
||||
; 4 16445406
|
||||
; 5 51507739
|
||||
|
||||
; Nboyer is a 2-phase benchmark.
|
||||
; The first phase attaches lemmas to symbols. This phase is not timed,
|
||||
; but it accounts for very little of the runtime anyway.
|
||||
; The second phase creates the test problem, and tests to see
|
||||
; whether it is implied by the lemmas.
|
||||
|
||||
(define (nboyer-benchmark . args)
|
||||
(let ((n (if (null? args) 0 (car args))))
|
||||
(setup-boyer)
|
||||
(run-benchmark (string-append "nboyer"
|
||||
(number->string n))
|
||||
1
|
||||
(lambda () (test-boyer n))
|
||||
(lambda (rewrites)
|
||||
(and (number? rewrites)
|
||||
(case n
|
||||
((0) (= rewrites 95024))
|
||||
((1) (= rewrites 591777))
|
||||
((2) (= rewrites 1813975))
|
||||
((3) (= rewrites 5375678))
|
||||
((4) (= rewrites 16445406))
|
||||
((5) (= rewrites 51507739))
|
||||
; If it works for n <= 5, assume it works.
|
||||
(else #t)))))))
|
||||
|
||||
(define (setup-boyer) #t) ; assigned below
|
||||
(define (test-boyer) #t) ; assigned below
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; The first phase.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; In the original benchmark, it stored a list of lemmas on the
|
||||
; property lists of symbols.
|
||||
; In the new benchmark, it maintains an association list of
|
||||
; symbols and symbol-records, and stores the list of lemmas
|
||||
; within the symbol-records.
|
||||
|
||||
(let ()
|
||||
|
||||
(define (setup)
|
||||
(add-lemma-lst
|
||||
(quote ((equal (compile form)
|
||||
(reverse (codegen (optimize form)
|
||||
(nil))))
|
||||
(equal (eqp x y)
|
||||
(equal (fix x)
|
||||
(fix y)))
|
||||
(equal (greaterp x y)
|
||||
(lessp y x))
|
||||
(equal (lesseqp x y)
|
||||
(not (lessp y x)))
|
||||
(equal (greatereqp x y)
|
||||
(not (lessp x y)))
|
||||
(equal (boolean x)
|
||||
(or (equal x (t))
|
||||
(equal x (f))))
|
||||
(equal (iff x y)
|
||||
(and (implies x y)
|
||||
(implies y x)))
|
||||
(equal (even1 x)
|
||||
(if (zerop x)
|
||||
(t)
|
||||
(odd (sub1 x))))
|
||||
(equal (countps- l pred)
|
||||
(countps-loop l pred (zero)))
|
||||
(equal (fact- i)
|
||||
(fact-loop i 1))
|
||||
(equal (reverse- x)
|
||||
(reverse-loop x (nil)))
|
||||
(equal (divides x y)
|
||||
(zerop (remainder y x)))
|
||||
(equal (assume-true var alist)
|
||||
(cons (cons var (t))
|
||||
alist))
|
||||
(equal (assume-false var alist)
|
||||
(cons (cons var (f))
|
||||
alist))
|
||||
(equal (tautology-checker x)
|
||||
(tautologyp (normalize x)
|
||||
(nil)))
|
||||
(equal (falsify x)
|
||||
(falsify1 (normalize x)
|
||||
(nil)))
|
||||
(equal (prime x)
|
||||
(and (not (zerop x))
|
||||
(not (equal x (add1 (zero))))
|
||||
(prime1 x (sub1 x))))
|
||||
(equal (and p q)
|
||||
(if p (if q (t)
|
||||
(f))
|
||||
(f)))
|
||||
(equal (or p q)
|
||||
(if p (t)
|
||||
(if q (t)
|
||||
(f))))
|
||||
(equal (not p)
|
||||
(if p (f)
|
||||
(t)))
|
||||
(equal (implies p q)
|
||||
(if p (if q (t)
|
||||
(f))
|
||||
(t)))
|
||||
(equal (fix x)
|
||||
(if (numberp x)
|
||||
x
|
||||
(zero)))
|
||||
(equal (if (if a b c)
|
||||
d e)
|
||||
(if a (if b d e)
|
||||
(if c d e)))
|
||||
(equal (zerop x)
|
||||
(or (equal x (zero))
|
||||
(not (numberp x))))
|
||||
(equal (plus (plus x y)
|
||||
z)
|
||||
(plus x (plus y z)))
|
||||
(equal (equal (plus a b)
|
||||
(zero))
|
||||
(and (zerop a)
|
||||
(zerop b)))
|
||||
(equal (difference x x)
|
||||
(zero))
|
||||
(equal (equal (plus a b)
|
||||
(plus a c))
|
||||
(equal (fix b)
|
||||
(fix c)))
|
||||
(equal (equal (zero)
|
||||
(difference x y))
|
||||
(not (lessp y x)))
|
||||
(equal (equal x (difference x y))
|
||||
(and (numberp x)
|
||||
(or (equal x (zero))
|
||||
(zerop y))))
|
||||
(equal (meaning (plus-tree (append x y))
|
||||
a)
|
||||
(plus (meaning (plus-tree x)
|
||||
a)
|
||||
(meaning (plus-tree y)
|
||||
a)))
|
||||
(equal (meaning (plus-tree (plus-fringe x))
|
||||
a)
|
||||
(fix (meaning x a)))
|
||||
(equal (append (append x y)
|
||||
z)
|
||||
(append x (append y z)))
|
||||
(equal (reverse (append a b))
|
||||
(append (reverse b)
|
||||
(reverse a)))
|
||||
(equal (times x (plus y z))
|
||||
(plus (times x y)
|
||||
(times x z)))
|
||||
(equal (times (times x y)
|
||||
z)
|
||||
(times x (times y z)))
|
||||
(equal (equal (times x y)
|
||||
(zero))
|
||||
(or (zerop x)
|
||||
(zerop y)))
|
||||
(equal (exec (append x y)
|
||||
pds envrn)
|
||||
(exec y (exec x pds envrn)
|
||||
envrn))
|
||||
(equal (mc-flatten x y)
|
||||
(append (flatten x)
|
||||
y))
|
||||
(equal (member x (append a b))
|
||||
(or (member x a)
|
||||
(member x b)))
|
||||
(equal (member x (reverse y))
|
||||
(member x y))
|
||||
(equal (length (reverse x))
|
||||
(length x))
|
||||
(equal (member a (intersect b c))
|
||||
(and (member a b)
|
||||
(member a c)))
|
||||
(equal (nth (zero)
|
||||
i)
|
||||
(zero))
|
||||
(equal (exp i (plus j k))
|
||||
(times (exp i j)
|
||||
(exp i k)))
|
||||
(equal (exp i (times j k))
|
||||
(exp (exp i j)
|
||||
k))
|
||||
(equal (reverse-loop x y)
|
||||
(append (reverse x)
|
||||
y))
|
||||
(equal (reverse-loop x (nil))
|
||||
(reverse x))
|
||||
(equal (count-list z (sort-lp x y))
|
||||
(plus (count-list z x)
|
||||
(count-list z y)))
|
||||
(equal (equal (append a b)
|
||||
(append a c))
|
||||
(equal b c))
|
||||
(equal (plus (remainder x y)
|
||||
(times y (quotient x y)))
|
||||
(fix x))
|
||||
(equal (power-eval (big-plus1 l i base)
|
||||
base)
|
||||
(plus (power-eval l base)
|
||||
i))
|
||||
(equal (power-eval (big-plus x y i base)
|
||||
base)
|
||||
(plus i (plus (power-eval x base)
|
||||
(power-eval y base))))
|
||||
(equal (remainder y 1)
|
||||
(zero))
|
||||
(equal (lessp (remainder x y)
|
||||
y)
|
||||
(not (zerop y)))
|
||||
(equal (remainder x x)
|
||||
(zero))
|
||||
(equal (lessp (quotient i j)
|
||||
i)
|
||||
(and (not (zerop i))
|
||||
(or (zerop j)
|
||||
(not (equal j 1)))))
|
||||
(equal (lessp (remainder x y)
|
||||
x)
|
||||
(and (not (zerop y))
|
||||
(not (zerop x))
|
||||
(not (lessp x y))))
|
||||
(equal (power-eval (power-rep i base)
|
||||
base)
|
||||
(fix i))
|
||||
(equal (power-eval (big-plus (power-rep i base)
|
||||
(power-rep j base)
|
||||
(zero)
|
||||
base)
|
||||
base)
|
||||
(plus i j))
|
||||
(equal (gcd x y)
|
||||
(gcd y x))
|
||||
(equal (nth (append a b)
|
||||
i)
|
||||
(append (nth a i)
|
||||
(nth b (difference i (length a)))))
|
||||
(equal (difference (plus x y)
|
||||
x)
|
||||
(fix y))
|
||||
(equal (difference (plus y x)
|
||||
x)
|
||||
(fix y))
|
||||
(equal (difference (plus x y)
|
||||
(plus x z))
|
||||
(difference y z))
|
||||
(equal (times x (difference c w))
|
||||
(difference (times c x)
|
||||
(times w x)))
|
||||
(equal (remainder (times x z)
|
||||
z)
|
||||
(zero))
|
||||
(equal (difference (plus b (plus a c))
|
||||
a)
|
||||
(plus b c))
|
||||
(equal (difference (add1 (plus y z))
|
||||
z)
|
||||
(add1 y))
|
||||
(equal (lessp (plus x y)
|
||||
(plus x z))
|
||||
(lessp y z))
|
||||
(equal (lessp (times x z)
|
||||
(times y z))
|
||||
(and (not (zerop z))
|
||||
(lessp x y)))
|
||||
(equal (lessp y (plus x y))
|
||||
(not (zerop x)))
|
||||
(equal (gcd (times x z)
|
||||
(times y z))
|
||||
(times z (gcd x y)))
|
||||
(equal (value (normalize x)
|
||||
a)
|
||||
(value x a))
|
||||
(equal (equal (flatten x)
|
||||
(cons y (nil)))
|
||||
(and (nlistp x)
|
||||
(equal x y)))
|
||||
(equal (listp (gopher x))
|
||||
(listp x))
|
||||
(equal (samefringe x y)
|
||||
(equal (flatten x)
|
||||
(flatten y)))
|
||||
(equal (equal (greatest-factor x y)
|
||||
(zero))
|
||||
(and (or (zerop y)
|
||||
(equal y 1))
|
||||
(equal x (zero))))
|
||||
(equal (equal (greatest-factor x y)
|
||||
1)
|
||||
(equal x 1))
|
||||
(equal (numberp (greatest-factor x y))
|
||||
(not (and (or (zerop y)
|
||||
(equal y 1))
|
||||
(not (numberp x)))))
|
||||
(equal (times-list (append x y))
|
||||
(times (times-list x)
|
||||
(times-list y)))
|
||||
(equal (prime-list (append x y))
|
||||
(and (prime-list x)
|
||||
(prime-list y)))
|
||||
(equal (equal z (times w z))
|
||||
(and (numberp z)
|
||||
(or (equal z (zero))
|
||||
(equal w 1))))
|
||||
(equal (greatereqp x y)
|
||||
(not (lessp x y)))
|
||||
(equal (equal x (times x y))
|
||||
(or (equal x (zero))
|
||||
(and (numberp x)
|
||||
(equal y 1))))
|
||||
(equal (remainder (times y x)
|
||||
y)
|
||||
(zero))
|
||||
(equal (equal (times a b)
|
||||
1)
|
||||
(and (not (equal a (zero)))
|
||||
(not (equal b (zero)))
|
||||
(numberp a)
|
||||
(numberp b)
|
||||
(equal (sub1 a)
|
||||
(zero))
|
||||
(equal (sub1 b)
|
||||
(zero))))
|
||||
(equal (lessp (length (delete x l))
|
||||
(length l))
|
||||
(member x l))
|
||||
(equal (sort2 (delete x l))
|
||||
(delete x (sort2 l)))
|
||||
(equal (dsort x)
|
||||
(sort2 x))
|
||||
(equal (length (cons x1
|
||||
(cons x2
|
||||
(cons x3 (cons x4
|
||||
(cons x5
|
||||
(cons x6 x7)))))))
|
||||
(plus 6 (length x7)))
|
||||
(equal (difference (add1 (add1 x))
|
||||
2)
|
||||
(fix x))
|
||||
(equal (quotient (plus x (plus x y))
|
||||
2)
|
||||
(plus x (quotient y 2)))
|
||||
(equal (sigma (zero)
|
||||
i)
|
||||
(quotient (times i (add1 i))
|
||||
2))
|
||||
(equal (plus x (add1 y))
|
||||
(if (numberp y)
|
||||
(add1 (plus x y))
|
||||
(add1 x)))
|
||||
(equal (equal (difference x y)
|
||||
(difference z y))
|
||||
(if (lessp x y)
|
||||
(not (lessp y z))
|
||||
(if (lessp z y)
|
||||
(not (lessp y x))
|
||||
(equal (fix x)
|
||||
(fix z)))))
|
||||
(equal (meaning (plus-tree (delete x y))
|
||||
a)
|
||||
(if (member x y)
|
||||
(difference (meaning (plus-tree y)
|
||||
a)
|
||||
(meaning x a))
|
||||
(meaning (plus-tree y)
|
||||
a)))
|
||||
(equal (times x (add1 y))
|
||||
(if (numberp y)
|
||||
(plus x (times x y))
|
||||
(fix x)))
|
||||
(equal (nth (nil)
|
||||
i)
|
||||
(if (zerop i)
|
||||
(nil)
|
||||
(zero)))
|
||||
(equal (last (append a b))
|
||||
(if (listp b)
|
||||
(last b)
|
||||
(if (listp a)
|
||||
(cons (car (last a))
|
||||
b)
|
||||
b)))
|
||||
(equal (equal (lessp x y)
|
||||
z)
|
||||
(if (lessp x y)
|
||||
(equal (t) z)
|
||||
(equal (f) z)))
|
||||
(equal (assignment x (append a b))
|
||||
(if (assignedp x a)
|
||||
(assignment x a)
|
||||
(assignment x b)))
|
||||
(equal (car (gopher x))
|
||||
(if (listp x)
|
||||
(car (flatten x))
|
||||
(zero)))
|
||||
(equal (flatten (cdr (gopher x)))
|
||||
(if (listp x)
|
||||
(cdr (flatten x))
|
||||
(cons (zero)
|
||||
(nil))))
|
||||
(equal (quotient (times y x)
|
||||
y)
|
||||
(if (zerop y)
|
||||
(zero)
|
||||
(fix x)))
|
||||
(equal (get j (set i val mem))
|
||||
(if (eqp j i)
|
||||
val
|
||||
(get j mem)))))))
|
||||
|
||||
(define (add-lemma-lst lst)
|
||||
(cond ((null? lst)
|
||||
#t)
|
||||
(else (add-lemma (car lst))
|
||||
(add-lemma-lst (cdr lst)))))
|
||||
|
||||
(define (add-lemma term)
|
||||
(cond ((and (pair? term)
|
||||
(eq? (car term)
|
||||
(quote equal))
|
||||
(pair? (cadr term)))
|
||||
(put (car (cadr term))
|
||||
(quote lemmas)
|
||||
(cons
|
||||
(translate-term term)
|
||||
(get (car (cadr term)) (quote lemmas)))))
|
||||
(else (error "ADD-LEMMA did not like term: " term))))
|
||||
|
||||
; Translates a term by replacing its constructor symbols by symbol-records.
|
||||
|
||||
(define (translate-term term)
|
||||
(cond ((not (pair? term))
|
||||
term)
|
||||
(else (cons (symbol->symbol-record (car term))
|
||||
(translate-args (cdr term))))))
|
||||
|
||||
(define (translate-args lst)
|
||||
(cond ((null? lst)
|
||||
'())
|
||||
(else (cons (translate-term (car lst))
|
||||
(translate-args (cdr lst))))))
|
||||
|
||||
; For debugging only, so the use of MAP does not change
|
||||
; the first-order character of the benchmark.
|
||||
|
||||
(define (untranslate-term term)
|
||||
(cond ((not (pair? term))
|
||||
term)
|
||||
(else (cons (get-name (car term))
|
||||
(map untranslate-term (cdr term))))))
|
||||
|
||||
; A symbol-record is represented as a vector with two fields:
|
||||
; the symbol (for debugging) and
|
||||
; the list of lemmas associated with the symbol.
|
||||
|
||||
(define (put sym property value)
|
||||
(put-lemmas! (symbol->symbol-record sym) value))
|
||||
|
||||
(define (get sym property)
|
||||
(get-lemmas (symbol->symbol-record sym)))
|
||||
|
||||
(define (symbol->symbol-record sym)
|
||||
(let ((x (assq sym *symbol-records-alist*)))
|
||||
(if x
|
||||
(cdr x)
|
||||
(let ((r (make-symbol-record sym)))
|
||||
(set! *symbol-records-alist*
|
||||
(cons (cons sym r)
|
||||
*symbol-records-alist*))
|
||||
r))))
|
||||
|
||||
; Association list of symbols and symbol-records.
|
||||
|
||||
(define *symbol-records-alist* '())
|
||||
|
||||
; A symbol-record is represented as a vector with two fields:
|
||||
; the symbol (for debugging) and
|
||||
; the list of lemmas associated with the symbol.
|
||||
|
||||
(define (make-symbol-record sym)
|
||||
(vector sym '()))
|
||||
|
||||
(define (put-lemmas! symbol-record lemmas)
|
||||
(vector-set! symbol-record 1 lemmas))
|
||||
|
||||
(define (get-lemmas symbol-record)
|
||||
(vector-ref symbol-record 1))
|
||||
|
||||
(define (get-name symbol-record)
|
||||
(vector-ref symbol-record 0))
|
||||
|
||||
(define (symbol-record-equal? r1 r2)
|
||||
(eq? r1 r2))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; The second phase.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (test n)
|
||||
(let ((term
|
||||
(apply-subst
|
||||
(translate-alist
|
||||
(quote ((x f (plus (plus a b)
|
||||
(plus c (zero))))
|
||||
(y f (times (times a b)
|
||||
(plus c d)))
|
||||
(z f (reverse (append (append a b)
|
||||
(nil))))
|
||||
(u equal (plus a b)
|
||||
(difference x y))
|
||||
(w lessp (remainder a b)
|
||||
(member a (length b))))))
|
||||
(translate-term
|
||||
(do ((term
|
||||
(quote (implies (and (implies x y)
|
||||
(and (implies y z)
|
||||
(and (implies z u)
|
||||
(implies u w))))
|
||||
(implies x w)))
|
||||
(list 'or term '(f)))
|
||||
(n n (- n 1)))
|
||||
((zero? n) term))))))
|
||||
(tautp term)))
|
||||
|
||||
(define (translate-alist alist)
|
||||
(cond ((null? alist)
|
||||
'())
|
||||
(else (cons (cons (caar alist)
|
||||
(translate-term (cdar alist)))
|
||||
(translate-alist (cdr alist))))))
|
||||
|
||||
(define (apply-subst alist term)
|
||||
(cond ((not (pair? term))
|
||||
(let ((temp-temp (assq term alist)))
|
||||
(if temp-temp
|
||||
(cdr temp-temp)
|
||||
term)))
|
||||
(else (cons (car term)
|
||||
(apply-subst-lst alist (cdr term))))))
|
||||
|
||||
(define (apply-subst-lst alist lst)
|
||||
(cond ((null? lst)
|
||||
'())
|
||||
(else (cons (apply-subst alist (car lst))
|
||||
(apply-subst-lst alist (cdr lst))))))
|
||||
|
||||
(define (tautp x)
|
||||
(tautologyp (rewrite x)
|
||||
'() '()))
|
||||
|
||||
(define (tautologyp x true-lst false-lst)
|
||||
(cond ((truep x true-lst)
|
||||
#t)
|
||||
((falsep x false-lst)
|
||||
#f)
|
||||
((not (pair? x))
|
||||
#f)
|
||||
((eq? (car x) if-constructor)
|
||||
(cond ((truep (cadr x)
|
||||
true-lst)
|
||||
(tautologyp (caddr x)
|
||||
true-lst false-lst))
|
||||
((falsep (cadr x)
|
||||
false-lst)
|
||||
(tautologyp (cadddr x)
|
||||
true-lst false-lst))
|
||||
(else (and (tautologyp (caddr x)
|
||||
(cons (cadr x)
|
||||
true-lst)
|
||||
false-lst)
|
||||
(tautologyp (cadddr x)
|
||||
true-lst
|
||||
(cons (cadr x)
|
||||
false-lst))))))
|
||||
(else #f)))
|
||||
|
||||
(define if-constructor '*) ; becomes (symbol->symbol-record 'if)
|
||||
|
||||
(define rewrite-count 0) ; sanity check
|
||||
|
||||
(define (rewrite term)
|
||||
(set! rewrite-count (+ rewrite-count 1))
|
||||
(cond ((not (pair? term))
|
||||
term)
|
||||
(else (rewrite-with-lemmas (cons (car term)
|
||||
(rewrite-args (cdr term)))
|
||||
(get-lemmas (car term))))))
|
||||
|
||||
(define (rewrite-args lst)
|
||||
(cond ((null? lst)
|
||||
'())
|
||||
(else (cons (rewrite (car lst))
|
||||
(rewrite-args (cdr lst))))))
|
||||
|
||||
(define (rewrite-with-lemmas term lst)
|
||||
(cond ((null? lst)
|
||||
term)
|
||||
((one-way-unify term (cadr (car lst)))
|
||||
(rewrite (apply-subst unify-subst (caddr (car lst)))))
|
||||
(else (rewrite-with-lemmas term (cdr lst)))))
|
||||
|
||||
(define unify-subst '*)
|
||||
|
||||
(define (one-way-unify term1 term2)
|
||||
(begin (set! unify-subst '())
|
||||
(one-way-unify1 term1 term2)))
|
||||
|
||||
(define (one-way-unify1 term1 term2)
|
||||
(cond ((not (pair? term2))
|
||||
(let ((temp-temp (assq term2 unify-subst)))
|
||||
(cond (temp-temp
|
||||
(term-equal? term1 (cdr temp-temp)))
|
||||
((number? term2) ; This bug fix makes
|
||||
(equal? term1 term2)) ; nboyer 10-25% slower!
|
||||
(else
|
||||
(set! unify-subst (cons (cons term2 term1)
|
||||
unify-subst))
|
||||
#t))))
|
||||
((not (pair? term1))
|
||||
#f)
|
||||
((eq? (car term1)
|
||||
(car term2))
|
||||
(one-way-unify1-lst (cdr term1)
|
||||
(cdr term2)))
|
||||
(else #f)))
|
||||
|
||||
(define (one-way-unify1-lst lst1 lst2)
|
||||
(cond ((null? lst1)
|
||||
(null? lst2))
|
||||
((null? lst2)
|
||||
#f)
|
||||
((one-way-unify1 (car lst1)
|
||||
(car lst2))
|
||||
(one-way-unify1-lst (cdr lst1)
|
||||
(cdr lst2)))
|
||||
(else #f)))
|
||||
|
||||
(define (falsep x lst)
|
||||
(or (term-equal? x false-term)
|
||||
(term-member? x lst)))
|
||||
|
||||
(define (truep x lst)
|
||||
(or (term-equal? x true-term)
|
||||
(term-member? x lst)))
|
||||
|
||||
(define false-term '*) ; becomes (translate-term '(f))
|
||||
(define true-term '*) ; becomes (translate-term '(t))
|
||||
|
||||
; The next two procedures were in the original benchmark
|
||||
; but were never used.
|
||||
|
||||
(define (trans-of-implies n)
|
||||
(translate-term
|
||||
(list (quote implies)
|
||||
(trans-of-implies1 n)
|
||||
(list (quote implies)
|
||||
0 n))))
|
||||
|
||||
(define (trans-of-implies1 n)
|
||||
(cond ((equal? n 1)
|
||||
(list (quote implies)
|
||||
0 1))
|
||||
(else (list (quote and)
|
||||
(list (quote implies)
|
||||
(- n 1)
|
||||
n)
|
||||
(trans-of-implies1 (- n 1))))))
|
||||
|
||||
; Translated terms can be circular structures, which can't be
|
||||
; compared using Scheme's equal? and member procedures, so we
|
||||
; use these instead.
|
||||
|
||||
(define (term-equal? x y)
|
||||
(cond ((pair? x)
|
||||
(and (pair? y)
|
||||
(symbol-record-equal? (car x) (car y))
|
||||
(term-args-equal? (cdr x) (cdr y))))
|
||||
(else (equal? x y))))
|
||||
|
||||
(define (term-args-equal? lst1 lst2)
|
||||
(cond ((null? lst1)
|
||||
(null? lst2))
|
||||
((null? lst2)
|
||||
#f)
|
||||
((term-equal? (car lst1) (car lst2))
|
||||
(term-args-equal? (cdr lst1) (cdr lst2)))
|
||||
(else #f)))
|
||||
|
||||
(define (term-member? x lst)
|
||||
(cond ((null? lst)
|
||||
#f)
|
||||
((term-equal? x (car lst))
|
||||
#t)
|
||||
(else (term-member? x (cdr lst)))))
|
||||
|
||||
(set! setup-boyer
|
||||
(lambda ()
|
||||
(set! *symbol-records-alist* '())
|
||||
(set! if-constructor (symbol->symbol-record 'if))
|
||||
(set! false-term (translate-term '(f)))
|
||||
(set! true-term (translate-term '(t)))
|
||||
(setup)))
|
||||
|
||||
(set! test-boyer
|
||||
(lambda (n)
|
||||
(set! rewrite-count 0)
|
||||
(let ((answer (test n)))
|
||||
(write rewrite-count)
|
||||
(display " rewrites")
|
||||
(newline)
|
||||
(if answer
|
||||
rewrite-count
|
||||
#f)))))
|
||||
|
||||
(should return this list)
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
2500
|
||||
"inputs/parsing.data"
|
||||
(should return this list)
|
||||
Binary file not shown.
|
|
@ -0,0 +1,16 @@
|
|||
1000
|
||||
|
||||
; example8
|
||||
|
||||
(lambda (input)
|
||||
(letrec ((reverse (lambda (in result)
|
||||
(if (pair? in)
|
||||
(reverse (cdr in) (cons (car in) result))
|
||||
result))))
|
||||
(reverse input '())))
|
||||
|
||||
((a b c d e f g h i j k l m n o p q r s t u v w x y z))
|
||||
|
||||
(lambda ()
|
||||
(list 'z 'y 'x 'w 'v 'u 't 's 'r 'q 'p 'o 'n
|
||||
'm 'l 'k 'j 'i 'h 'g 'f 'e 'd 'c 'b 'a))
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
1
|
||||
50
|
||||
500
|
||||
50
|
||||
|
||||
((314159265358979323846264338327950288419716939937507
|
||||
-54
|
||||
124)
|
||||
(31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170673
|
||||
-51
|
||||
-417)
|
||||
(3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408122
|
||||
-57
|
||||
-819)
|
||||
(314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038195
|
||||
-76
|
||||
332)
|
||||
(31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019089
|
||||
-83
|
||||
477)
|
||||
(3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141268
|
||||
-72
|
||||
-2981)
|
||||
(314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536431
|
||||
-70
|
||||
-2065)
|
||||
(31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019091456485669234603486104543266482133936072602491412737245870066063155881748815209209628292540917153643678925903600113305305488204665213841469519415116089
|
||||
-79
|
||||
1687)
|
||||
(3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141273724587006606315588174881520920962829254091715364367892590360011330530548820466521384146951941511609433057270365759591953092186117381932611793105118542
|
||||
-92
|
||||
-2728)
|
||||
(314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536436789259036001133053054882046652138414695194151160943305727036575959195309218611738193261179310511854807446237996274956735188575272489122793818301194907
|
||||
-76
|
||||
-3726))
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
500000
|
||||
#(0. 1. 1. 0. 0. 1. -.5 -1. -1. -2. -2.5 -2. -1.5 -.5 1. 1. 0. -.5 -1. -.5)
|
||||
#(0. 0. 1. 1. 2. 3. 2. 3. 0. -.5 -1. -1.5 -2. -2. -1.5 -1. -.5 -1. -1. -.5)
|
||||
6
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
5000
|
||||
1000
|
||||
(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79
|
||||
83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163
|
||||
167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251
|
||||
257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349
|
||||
353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443
|
||||
449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557
|
||||
563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647
|
||||
653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757
|
||||
761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863
|
||||
877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983
|
||||
991 997)
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
500
|
||||
511
|
||||
2005
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
2500
|
||||
10000
|
||||
1000000
|
||||
ignored
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
20
|
||||
1
|
||||
"outputs/ray.output"
|
||||
ok
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
1
|
||||
0
|
||||
#x10ffff
|
||||
ignored
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
2500
|
||||
|
||||
"inputs/parsing.data"
|
||||
|
||||
(should return this list)
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
2500
|
||||
|
||||
"inputs/parsing.data"
|
||||
|
||||
(should return this list)
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
2500
|
||||
|
||||
"inputs/parsing16.data"
|
||||
|
||||
(should return this list)
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
1
|
||||
5
|
||||
51507739 ; if the input is 5
|
||||
16445406 ; if the input is 4
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
100000
|
||||
|
||||
(let ()
|
||||
|
||||
(define (sort-list obj pred)
|
||||
|
||||
(define (loop l)
|
||||
(if (and (pair? l) (pair? (cdr l)))
|
||||
(split l '() '())
|
||||
l))
|
||||
|
||||
(define (split l one two)
|
||||
(if (pair? l)
|
||||
(split (cdr l) two (cons (car l) one))
|
||||
(merge (loop one) (loop two))))
|
||||
|
||||
(define (merge one two)
|
||||
(cond ((null? one) two)
|
||||
((pred (car two) (car one))
|
||||
(cons (car two)
|
||||
(merge (cdr two) one)))
|
||||
(else
|
||||
(cons (car one)
|
||||
(merge (cdr one) two)))))
|
||||
|
||||
(loop obj))
|
||||
|
||||
(sort-list '("one" "two" "three" "four" "five" "six"
|
||||
"seven" "eight" "nine" "ten" "eleven" "twelve"
|
||||
"thirteen" "fourteen" "fifteen" "sixteen"
|
||||
"seventeen" "eighteen" "nineteen" "twenty"
|
||||
"twentyone" "twentytwo" "twentythree" "twentyfour"
|
||||
"twentyfive" "twentysix" "twentyseven" "twentyeight"
|
||||
"twentynine" "thirty")
|
||||
string<?))
|
||||
|
||||
("eight" "eighteen" "eleven" "fifteen" "five" "four" "fourteen"
|
||||
"nine" "nineteen" "one" "seven" "seventeen" "six" "sixteen"
|
||||
"ten" "thirteen" "thirty" "three" "twelve" "twenty" "twentyeight"
|
||||
"twentyfive" "twentyfour" "twentynine" "twentyone" "twentyseven"
|
||||
"twentysix" "twentythree" "twentytwo" "two")
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
1000000
|
||||
740.0
|
||||
(#(4 1 3 2) #(0 5 7 6))
|
||||
|
||||
|
|
@ -0,0 +1,547 @@
|
|||
% slatex.sty
|
||||
% SLaTeX v. 2.2
|
||||
% style file to be used in (La)TeX when using SLaTeX
|
||||
% (c) Dorai Sitaram, Rice U., 1991, 1994
|
||||
|
||||
% This file (or a soft link to it) should be in some
|
||||
% directory in your TEXINPUTS path (i.e., the one
|
||||
% (La)TeX scours for \input or \documentstyle option
|
||||
% files).
|
||||
|
||||
% Do not attempt to debug this file, since the results
|
||||
% are not transparent just to (La)TeX. The Scheme part
|
||||
% of SLaTeX depends on information laid out here -- so
|
||||
% (La)TeX-minded debugging of this file will almost
|
||||
% inevitably sabotage SLaTeX.
|
||||
|
||||
% It's possible you don't find the default style set
|
||||
% out here appealing: e.g., you may want to change the
|
||||
% positioning of displayed code; change the fonts for
|
||||
% keywords, constants, and variables; add new keywords,
|
||||
% constants, and variables; use your names instead of
|
||||
% the provided \scheme, [\begin|\end]{schemedisplay},
|
||||
% [\begin|\end]{schemebox}, (or \[end]schemedisplay,
|
||||
% \[end]schemebox for TeX), which might be seem too
|
||||
% long or unmnemonic, and many other things. The clean
|
||||
% way to do these things is outlined in the
|
||||
% accompanying manual, slatex-d.tex. This way is both
|
||||
% easier than messing with this .sty file, and safer
|
||||
% since you will not unwittingly break SLaTeX.
|
||||
|
||||
%%%
|
||||
|
||||
% to prevent loading slatex.sty more than once
|
||||
|
||||
\ifx\slatexignorecurrentfile\UNDEFINED
|
||||
\else\endinput\fi
|
||||
|
||||
% use \slatexignorecurrentfile to disable slatex for
|
||||
% the current file. (Unstrangely, the very definition
|
||||
% disables slatex for the rest of _this_ file, slatex.sty.)
|
||||
|
||||
\def\slatexignorecurrentfile{}
|
||||
|
||||
% checking whether we're using LaTeX or TeX?
|
||||
|
||||
\newif\ifusinglatex
|
||||
\ifx\newenvironment\UNDEFINED\usinglatexfalse\else\usinglatextrue\fi
|
||||
|
||||
% make @ a letter for TeX
|
||||
\ifusinglatex\relax\else
|
||||
\edef\atcatcodebeforeslatex{\the\catcode`@}
|
||||
\catcode`@11
|
||||
\fi
|
||||
|
||||
% identification of TeX/LaTeX style for schemedisplay.
|
||||
% Do \defslatexenvstyle{tex} to get TeX environment
|
||||
% style in LaTeX
|
||||
\def\defslatexenvstyle#1{\gdef\slatexenvstyle{#1}}
|
||||
|
||||
\ifusinglatex\defslatexenvstyle{latex}\else\defslatexenvstyle{tex}\fi
|
||||
|
||||
% TeX doesn't have sans-serif; use roman instead
|
||||
\ifx\sf\UNDEFINED\def\sf{\rm}\fi
|
||||
|
||||
% tabbing from plain TeX
|
||||
%
|
||||
\newif\ifus@ \newif\if@cr
|
||||
\newbox\tabs \newbox\tabsyet \newbox\tabsdone
|
||||
%
|
||||
\def\cleartabs{\global\setbox\tabsyet\null \setbox\tabs\null}
|
||||
\def\settabs{\setbox\tabs\null \futurelet\next\sett@b}
|
||||
\let\+=\relax % in case this file is being read in twice
|
||||
\def\sett@b{\ifx\next\+\let\next\relax
|
||||
\def\next{\afterassignment\s@tt@b\let\next}%
|
||||
\else\let\next\s@tcols\fi\next}
|
||||
\def\s@tt@b{\let\next\relax\us@false\m@ketabbox}
|
||||
\def\tabalign{\us@true\m@ketabbox} % non-\outer version of \+
|
||||
\outer\def\+{\tabalign}
|
||||
\def\s@tcols#1\columns{\count@#1 \dimen@\hsize
|
||||
\loop\ifnum\count@>\z@ \@nother \repeat}
|
||||
\def\@nother{\dimen@ii\dimen@ \divide\dimen@ii\count@
|
||||
\setbox\tabs\hbox{\hbox to\dimen@ii{}\unhbox\tabs}%
|
||||
\advance\dimen@-\dimen@ii \advance\count@\m@ne}
|
||||
%
|
||||
\def\m@ketabbox{\begingroup
|
||||
\global\setbox\tabsyet\copy\tabs
|
||||
\global\setbox\tabsdone\null
|
||||
\def\cr{\@crtrue\crcr\egroup\egroup
|
||||
\ifus@\unvbox\z@\lastbox\fi\endgroup
|
||||
\setbox\tabs\hbox{\unhbox\tabsyet\unhbox\tabsdone}}%
|
||||
\setbox\z@\vbox\bgroup\@crfalse
|
||||
\ialign\bgroup&\t@bbox##\t@bb@x\crcr}
|
||||
%
|
||||
\def\t@bbox{\setbox\z@\hbox\bgroup}
|
||||
\def\t@bb@x{\if@cr\egroup % now \box\z@ holds the column
|
||||
\else\hss\egroup \global\setbox\tabsyet\hbox{\unhbox\tabsyet
|
||||
\global\setbox\@ne\lastbox}% now \box\@ne holds its size
|
||||
\ifvoid\@ne\global\setbox\@ne\hbox to\wd\z@{}%
|
||||
\else\setbox\z@\hbox to\wd\@ne{\unhbox\z@}\fi
|
||||
\global\setbox\tabsdone\hbox{\box\@ne\unhbox\tabsdone}\fi
|
||||
\box\z@}
|
||||
% finished (re)defining TeX's tabbing macros
|
||||
|
||||
% above from plain.tex; was disabled in lplain.tex. Do
|
||||
% not modify above unless you really know what you're
|
||||
% up to. Make all changes you want to following code.
|
||||
% The new env is preferable to LaTeX's tabbing env
|
||||
% since latter accepts only a small number of tabs
|
||||
|
||||
% following retrieves something like LaTeX's tabbing
|
||||
% env without the above problem (it also creates a box
|
||||
% for easy manipulation!)
|
||||
|
||||
\def\lat@xtabbing{\leavevmode\hbox\bgroup\vbox\bgroup
|
||||
\def\={\cleartabs&} \def\>{&} \def\\{\cr\tabalign} \tabalign}
|
||||
\def\endlat@xtabbing{\cr\egroup\egroup}
|
||||
|
||||
%new
|
||||
|
||||
\def\lat@xtabbing{\begingroup
|
||||
\def\={\cleartabs&} \def\>{&}%
|
||||
\def\\{\cr\tabalign\lat@xtabbingleftmost}%
|
||||
\tabalign\lat@xtabbingleftmost}
|
||||
\def\endlat@xtabbing{\cr\endgroup}
|
||||
\let\lat@xtabbingleftmost\relax
|
||||
|
||||
% stuff for formating Scheme code
|
||||
|
||||
\newskip\par@nlen \newskip\brack@tlen \newskip\quot@len
|
||||
\newskip\h@lflambda
|
||||
|
||||
\newbox\garb@ge
|
||||
\def\s@ttowidth#1#2{\setbox\garb@ge\hbox{#2}#1\wd\garb@ge\relax}
|
||||
|
||||
\s@ttowidth\par@nlen{$($} % size of paren
|
||||
\s@ttowidth\brack@tlen{$[$} % size of bracket
|
||||
\s@ttowidth\quot@len{'} % size of quote indentation
|
||||
\s@ttowidth\h@lflambda{ii} % size of half of lambda indentation
|
||||
|
||||
\def\PRN{\hskip\par@nlen} % these are used by SLaTeX's codesetter
|
||||
\def\BKT{\hskip\brack@tlen}
|
||||
\def\QUO{\hskip\quot@len}
|
||||
\def\HL{\hskip\h@lflambda}
|
||||
|
||||
\newskip\abovecodeskip \newskip\belowcodeskip
|
||||
\newskip\leftcodeskip \newskip\rightcodeskip
|
||||
|
||||
% the following default assignments give a flushleft
|
||||
% display
|
||||
|
||||
\abovecodeskip=\medskipamount \belowcodeskip=\medskipamount
|
||||
\leftcodeskip=0pt \rightcodeskip=0pt
|
||||
|
||||
% adjust above,below,left,right codeskip's to personal
|
||||
% taste
|
||||
|
||||
% for centered displays
|
||||
%
|
||||
% \leftcodeskip=0pt plus 1fil
|
||||
% \rightcodeskip=0pt plus 1fil
|
||||
%
|
||||
% if \rightcodeskip != 0pt, pagebreaks within Scheme
|
||||
% blocks in {schemedisplay} are disabled
|
||||
|
||||
\def\checkfollpar{\futurelet\next\checkfollparII}
|
||||
\def\checkfollparII{\ifx\next\par\let\next\relax
|
||||
\else\par\noindent\let\next\ignorespaces\fi\next}
|
||||
|
||||
% the following are the default font assignments for
|
||||
% words in code. Change them to suit personal taste
|
||||
|
||||
\def\keywordfont#1{{\bf #1}}
|
||||
\def\variablefont#1{{\it #1\/}}
|
||||
\def\constantfont#1{{\sf #1}}
|
||||
\def\datafont#1{\constantfont{#1}}
|
||||
|
||||
\def\schemecodehook{}
|
||||
|
||||
%program listings that allow page breaks but
|
||||
%can't be centered
|
||||
|
||||
\def\ZZZZschemedisplay{\edef\thez@skip{\the\z@skip}%
|
||||
\edef\@tempa{\the\rightcodeskip}%
|
||||
\ifx\@tempa\thez@skip\let\next\ZZZZschemeprogram
|
||||
\else\let\next\ZZZZschemeprogramII\fi\next}
|
||||
|
||||
\def\endZZZZschemedisplay{\edef\thez@skip{\the\z@skip}%
|
||||
\edef\@tempa{\the\rightcodeskip}%
|
||||
\ifx\@tempa\thez@skip\let\next\endZZZZschemeprogram
|
||||
\else\let\next\endZZZZschemeprogramII\fi\next}
|
||||
|
||||
\def\ZZZZschemeprogram{\vskip\abovecodeskip
|
||||
\begingroup
|
||||
\schemecodehook
|
||||
\let\sy=\keywordfont \let\cn=\constantfont
|
||||
\let\va=\variablefont \let\dt=\datafont
|
||||
\def\lat@xtabbingleftmost{\hskip\leftcodeskip\relax}%
|
||||
\lat@xtabbing}
|
||||
|
||||
\def\endZZZZschemeprogram{\endlat@xtabbing
|
||||
\endgroup
|
||||
\vskip\belowcodeskip
|
||||
\ifusinglatex\let\next\@endparenv
|
||||
\else\let\next\checkfollpar\fi\next}
|
||||
|
||||
\def\ZZZZschemeprogramII{\vskip\abovecodeskip
|
||||
\begingroup
|
||||
\noindent
|
||||
%\schemecodehook %\ZZZZschemebox already has it
|
||||
\hskip\leftcodeskip
|
||||
\ZZZZschemebox}
|
||||
|
||||
\def\endZZZZschemeprogramII{\endZZZZschemebox
|
||||
\hskip\rightcodeskip
|
||||
\endgroup
|
||||
\vskip\belowcodeskip
|
||||
\ifusinglatex\let\next\@endparenv
|
||||
\else\let\next\checkfollpar\fi\next}
|
||||
|
||||
%
|
||||
|
||||
\def\ZZZZschemebox{%
|
||||
\leavevmode\hbox\bgroup\vbox\bgroup
|
||||
\schemecodehook
|
||||
\let\sy=\keywordfont \let\cn=\constantfont
|
||||
\let\va=\variablefont \let\dt=\datafont
|
||||
\lat@xtabbing}
|
||||
\def\endZZZZschemebox{\endlat@xtabbing
|
||||
\egroup\egroup\ignorespaces}
|
||||
|
||||
%in-text
|
||||
|
||||
\def\ZZZZschemecodeintext{\begingroup
|
||||
\let\sy\keywordfont \let\cn\constantfont
|
||||
\let\va\variablefont \let\dt\datafont}
|
||||
|
||||
\def\endZZZZschemecodeintext{\endgroup\ignorespaces}
|
||||
|
||||
\def\ZZZZschemeresultintext{\begingroup
|
||||
\let\sy\datafont \let\cn\constantfont
|
||||
\let\va\datafont \let\dt\datafont}
|
||||
|
||||
\def\endZZZZschemeresultintext{\endgroup\ignorespaces}
|
||||
|
||||
% \comm@nt<some-char>...text...<same-char> comments out
|
||||
% TeX source analogous to
|
||||
% \verb<some-char>...text...<same-char>. Sp. case:
|
||||
% \comm@nt{...text...} == \comm@nt}...text...}
|
||||
|
||||
\def\@makeother#1{\catcode`#112\relax}
|
||||
|
||||
\def\comm@nt{%
|
||||
\begingroup
|
||||
\let\do\@makeother \dospecials
|
||||
\@comm}
|
||||
|
||||
\begingroup\catcode`\<1\catcode`\>2
|
||||
\catcode`\{12\catcode`\}12
|
||||
\long\gdef\@comm#1<%
|
||||
\if#1{\long\def\@tempa ##1}<\endgroup>\else
|
||||
\long\def\@tempa ##1#1<\endgroup>\fi
|
||||
\@tempa>
|
||||
\endgroup
|
||||
|
||||
% input file if possible, else relax
|
||||
|
||||
\def\inputifpossible#1{%
|
||||
\immediate\openin0=#1\relax%
|
||||
\ifeof0\relax\else\input#1\relax\fi%
|
||||
\immediate\closein0}
|
||||
|
||||
\def\ZZZZinput#1{\input#1\relax}
|
||||
|
||||
% you may replace the above by
|
||||
%
|
||||
% \def\ZZZZinput#1{\inputifpossible{#1}}
|
||||
%
|
||||
% if you just want to call (La)TeX on your text
|
||||
% ignoring the portions that need to be SLaTeX'ed
|
||||
|
||||
%use \subjobname rather than \jobname to generate
|
||||
%slatex's temp files --- this allows us to change
|
||||
%\subjobname for more control, if necessary.
|
||||
|
||||
\let\subjobname\jobname
|
||||
|
||||
% counter for generating temp file names
|
||||
|
||||
\newcount\sch@mefilenamecount
|
||||
\sch@mefilenamecount=-1
|
||||
|
||||
% To produce displayed Scheme code:
|
||||
% in LaTeX:
|
||||
% \begin{schemedisplay}
|
||||
% ... indented program (with sev'l lines) ...
|
||||
% \end{schemedisplay}
|
||||
%
|
||||
% in TeX:
|
||||
% \schemedisplay
|
||||
% ... indented program (with sev'l lines) ...
|
||||
% \endschemedisplay
|
||||
|
||||
\begingroup\catcode`\|=0\catcode`\[=1\catcode`\]=2%
|
||||
\catcode`\{=12\catcode`\}=12\catcode`\\=12%
|
||||
|gdef|defschemedisplaytoken#1[%
|
||||
|long|expandafter|gdef|csname ZZZZcomment#1|endcsname[%
|
||||
|begingroup
|
||||
|let|do|@makeother |dospecials
|
||||
|csname ZZZZcomment|slatexenvstyle II#1|endcsname]%
|
||||
|long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[%
|
||||
|endgroup|end[#1]]%
|
||||
|long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[%
|
||||
|endgroup|csname end#1|endcsname]%
|
||||
|long|expandafter|gdef|csname #1|endcsname[%
|
||||
|global|advance|sch@mefilenamecount by 1|relax%
|
||||
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|
||||
|csname ZZZZcomment#1|endcsname]%
|
||||
|long|expandafter|gdef|csname end#1|endcsname[]]%
|
||||
|endgroup
|
||||
|
||||
\defschemedisplaytoken{schemedisplay}
|
||||
|
||||
\def\undefschemedisplaytoken#1{%
|
||||
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
|
||||
|
||||
% \scheme|...program fragment...| produces Scheme code
|
||||
% in-text. Sp. case: \scheme{...} == \scheme}...}
|
||||
|
||||
\def\defschemetoken#1{%
|
||||
\long\expandafter\def\csname#1\endcsname{%
|
||||
\global\advance\sch@mefilenamecount by 1\relax%
|
||||
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}%
|
||||
\comm@nt}}
|
||||
\defschemetoken{scheme}
|
||||
|
||||
\def\undefschemetoken#1{%
|
||||
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
|
||||
|
||||
% \schemeresult|...program fragment...| produces a
|
||||
% Scheme code result in-text: i.e. keyword or variable
|
||||
% fonts are replaced by the data font. Sp. case:
|
||||
% \schemeresult{...} == \schemeresult}...}
|
||||
|
||||
\def\defschemeresulttoken#1{%
|
||||
\long\expandafter\def\csname#1\endcsname{%
|
||||
\global\advance\sch@mefilenamecount by 1\relax%
|
||||
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}%
|
||||
\comm@nt}}
|
||||
\defschemeresulttoken{schemeresult}
|
||||
|
||||
\def\undefschemeresulttoken#1{%
|
||||
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
|
||||
|
||||
% To produce a box of Scheme code:
|
||||
% in LaTeX:
|
||||
% \begin{schemebox}
|
||||
% ... indented program (with sev'l lines) ...
|
||||
% \end{schemebox}
|
||||
%
|
||||
% in TeX:
|
||||
% \schemebox
|
||||
% ... indented program (with sev'l lines) ...
|
||||
% \endschemebox
|
||||
|
||||
\begingroup\catcode`\|=0\catcode`\[=1\catcode`\]=2%
|
||||
\catcode`\{=12\catcode`\}=12\catcode`\\=12%
|
||||
|gdef|defschemeboxtoken#1[%
|
||||
|long|expandafter|gdef|csname ZZZZcomment#1|endcsname[%
|
||||
|begingroup
|
||||
|let|do|@makeother |dospecials
|
||||
|csname ZZZZcomment|slatexenvstyle II#1|endcsname]%
|
||||
|long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[%
|
||||
|endgroup|end[#1]]%
|
||||
|long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[%
|
||||
|endgroup|csname end#1|endcsname]%
|
||||
|long|expandafter|gdef|csname #1|endcsname[%
|
||||
|global|advance|sch@mefilenamecount by 1|relax%
|
||||
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|
||||
|csname ZZZZcomment#1|endcsname]%
|
||||
|long|expandafter|gdef|csname end#1|endcsname[]]%
|
||||
|endgroup
|
||||
|
||||
\defschemeboxtoken{schemebox}
|
||||
|
||||
\def\undefschemeboxtoken#1{%
|
||||
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
|
||||
|
||||
% for wholesale dumping of all-Scheme files into TeX (converting
|
||||
% .scm files to .tex),
|
||||
% use
|
||||
% \schemeinput{<filename>}
|
||||
% .scm, .ss, .s extensions optional
|
||||
|
||||
\def\defschemeinputtoken#1{%
|
||||
\long\expandafter\gdef\csname#1\endcsname##1{%
|
||||
\global\advance\sch@mefilenamecount by 1\relax%
|
||||
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}}}
|
||||
\defschemeinputtoken{schemeinput}
|
||||
|
||||
\def\undefschemeinputtoken#1{%
|
||||
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
|
||||
|
||||
% delineating a region that features typeset code
|
||||
% not usually needed, except when using \scheme and schemedisplay
|
||||
% inside macro-args and macro-definition-bodies
|
||||
% in LaTeX:
|
||||
% \begin{schemeregion}
|
||||
% ...
|
||||
% \end{schemeregion}
|
||||
%
|
||||
% in TeX:
|
||||
% \schemeregion
|
||||
% ...
|
||||
% \endschemeregion
|
||||
|
||||
\begingroup\catcode`\|=0\catcode`\[=1\catcode`\]=2%
|
||||
\catcode`\{=12\catcode`\}=12\catcode`\\=12%
|
||||
|gdef|defschemeregiontoken#1[%
|
||||
|long|expandafter|gdef|csname ZZZZcomment#1|endcsname[%
|
||||
|begingroup
|
||||
|let|do|@makeother |dospecials
|
||||
|csname ZZZZcomment|slatexenvstyle II#1|endcsname]%
|
||||
|long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[%
|
||||
|endgroup|end[#1]]%
|
||||
|long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[%
|
||||
|endgroup|csname end#1|endcsname]%
|
||||
|long|expandafter|gdef|csname #1|endcsname[%
|
||||
|global|advance|sch@mefilenamecount by 1|relax%
|
||||
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|
||||
|csname ZZZZcomment#1|endcsname]%
|
||||
|long|expandafter|gdef|csname end#1|endcsname[]]%
|
||||
|endgroup
|
||||
|
||||
\defschemeregiontoken{schemeregion}
|
||||
|
||||
\def\undefschemeregiontoken#1{%
|
||||
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
|
||||
|
||||
% introducing new code-tokens to the keyword, variable and constant
|
||||
% categories
|
||||
|
||||
\def\comm@ntII{%
|
||||
\begingroup
|
||||
\let\do\@makeother \dospecials
|
||||
\@commII}
|
||||
|
||||
\begingroup\catcode`\[1\catcode`\]2
|
||||
\catcode`\{12\catcode`\}12
|
||||
\long\gdef\@commII{[%
|
||||
\long\def\@tempa ##1}[\endgroup]\@tempa]%
|
||||
\endgroup
|
||||
|
||||
\let\setkeyword\comm@ntII
|
||||
\let\setvariable\comm@ntII
|
||||
\let\setconstant\comm@ntII
|
||||
|
||||
% \defschememathescape makes the succeeding grouped character an
|
||||
% escape into latex math from within Scheme code;
|
||||
% this character can't be }
|
||||
|
||||
\let\defschememathescape\comm@ntII
|
||||
\let\undefschememathescape\comm@ntII
|
||||
|
||||
% telling SLaTeX that a certain Scheme identifier is to
|
||||
% be replaced by the specified LaTeX expression.
|
||||
% Useful for generating ``mathematical''-looking
|
||||
% typeset code even though the corresponding Scheme
|
||||
% code is ascii as usual and doesn't violate
|
||||
% identifier-naming rules
|
||||
|
||||
\def\setspecialsymbol{%
|
||||
\begingroup
|
||||
\let\do\@makeother \dospecials
|
||||
\@commIII}
|
||||
|
||||
\begingroup\catcode`\[1\catcode`\]2
|
||||
\catcode`\{12\catcode`\}12
|
||||
\long\gdef\@commIII{[%
|
||||
\long\def\@tempa ##1}[\endgroup\@gobbleI]\@tempa]%
|
||||
\endgroup
|
||||
|
||||
\def\@gobbleI#1{}
|
||||
|
||||
% \unsetspecialsymbol strips Scheme identifier(s) of
|
||||
% any ``mathematical'' look lent by the above
|
||||
|
||||
\let\unsetspecialsymbol\comm@ntII
|
||||
|
||||
% enabling/disabling slatex
|
||||
|
||||
\def\slatexdisable#1{\expandafter\gdef\csname#1\endcsname{}}
|
||||
|
||||
% \schemecasesensitive takes either true or false as
|
||||
% argument
|
||||
|
||||
\def\schemecasesensitive#1{}
|
||||
|
||||
%for latex only: use \slatexseparateincludes before the
|
||||
%occurrence of any Scheme code in your file, if you
|
||||
%want the various \include'd files to have their own
|
||||
%pool of temporary slatex files. This lets you juggle
|
||||
%your \include's in successive runs of LaTeX without
|
||||
%having to worry that the temp. files may interfere.
|
||||
%By default, only a single pool of temp files is used.
|
||||
%Warning: On DOS, if your \include'd files have fairly
|
||||
%similar names, avoid \slatexseparateincludes since the
|
||||
%short filenames on DOS will likely confuse the temp
|
||||
%file pools of different \include files.
|
||||
|
||||
\def\slatexseparateincludes{%
|
||||
\gdef\include##1{{\def\subjobname{##1}%
|
||||
\sch@mefilenamecount=-1%
|
||||
\@include##1 }}}
|
||||
|
||||
% convenient abbreviations for characters
|
||||
|
||||
\begingroup
|
||||
\catcode`\|=0
|
||||
|catcode`|\=12
|
||||
|gdef|ttbackslash{{|tt|catcode`|\=12\}}
|
||||
|endgroup
|
||||
\mathchardef\lt="313C
|
||||
\mathchardef\gt="313E
|
||||
\begingroup
|
||||
\catcode`\@12%
|
||||
\global\let\atsign@%
|
||||
\endgroup
|
||||
\chardef\dq=`\"
|
||||
|
||||
% leading character of slatex filenames: . for unix to
|
||||
% keep them out of the way
|
||||
|
||||
\def\filehider{.}
|
||||
|
||||
% since the above doesn't work of dos, slatex on dos
|
||||
% will use a different character, and make the
|
||||
% redefinition available through the following
|
||||
|
||||
\inputifpossible{xZfilhid.tex}
|
||||
|
||||
% @ is no longer a letter for TeX
|
||||
|
||||
\ifusinglatex\relax\else
|
||||
\catcode`@\atcatcodebeforeslatex
|
||||
\fi
|
||||
|
||||
\message{*** Check: Are you sure you called SLaTeX? ***}
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,4 @@
|
|||
100
|
||||
"inputs/slatex-data/test"
|
||||
ignored
|
||||
ignored
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
10
|
||||
500000
|
||||
524278
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
100000
|
||||
10000
|
||||
50005000
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,3 @@
|
|||
10
|
||||
"inputs/sum1.data"
|
||||
15794.975
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
250
|
||||
1e6
|
||||
5.000005e11
|
||||
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
10
|
||||
"inputs/bib"
|
||||
"outputs/tail.output"
|
||||
ignored
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
10
|
||||
32
|
||||
16
|
||||
8
|
||||
9
|
||||
|
||||
|
||||
; The old inputs and output for tak were:
|
||||
|
||||
3000
|
||||
18
|
||||
12
|
||||
6
|
||||
7
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
2
|
||||
|
||||
(32 31 30 29 28 27 26 25 24 23 22 21
|
||||
20 19 18 17 16 15 14 13 12 11
|
||||
10 9 8 7 6 5 4 3 2 1)
|
||||
|
||||
( 16 15 14 13 12 11
|
||||
10 9 8 7 6 5 4 3 2 1)
|
||||
|
||||
(8 7 6 5 4 3 2 1)
|
||||
|
||||
9
|
||||
|
||||
|
||||
; The old inputs and output for takl were:
|
||||
|
||||
600
|
||||
(a list of 18 elements)
|
||||
(a list of 12 elements)
|
||||
(a list of 6 elements)
|
||||
7
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
50
|
||||
22
|
||||
1
|
||||
(22 34 31 15 7 1 20 17 25 6 5 13 32)
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
1
|
||||
0
|
||||
#x10ffff
|
||||
ignored
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
25
|
||||
"inputs/bib"
|
||||
(31102 851820 4460056)
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
;;; ACK -- One of the Kernighan and Van Wyk benchmarks.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
|
||||
(define (ack m n)
|
||||
(cond ((= m 0) (+ n 1))
|
||||
((= n 0) (ack (- m 1) 1))
|
||||
(else (ack (- m 1) (ack m (- n 1))))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(input2 (read))
|
||||
(output (read))
|
||||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "ack"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (ack (hide count input1) (hide count input2)))
|
||||
(lambda (result) (= result output)))))
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
;;; ARRAY1 -- One of the Kernighan and Van Wyk benchmarks.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
|
||||
(define (create-x n)
|
||||
(define result (make-vector n))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((>= i n) result)
|
||||
(vector-set! result i i)))
|
||||
|
||||
(define (create-y x)
|
||||
(let* ((n (vector-length x))
|
||||
(result (make-vector n)))
|
||||
(do ((i (- n 1) (- i 1)))
|
||||
((< i 0) result)
|
||||
(vector-set! result i (vector-ref x i)))))
|
||||
|
||||
(define (my-try n)
|
||||
(vector-length (create-y (create-x n))))
|
||||
|
||||
(define (go m n)
|
||||
(let loop ((repeat m)
|
||||
(result '()))
|
||||
(if (> repeat 0)
|
||||
(loop (- repeat 1) (my-try n))
|
||||
result)))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "array1"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
1
|
||||
(lambda () (go (hide count count) (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
|
@ -0,0 +1,65 @@
|
|||
;;; find the most frequently referenced word in the bible.
|
||||
;;; aziz ghuloum (Nov 2007)
|
||||
;;; modified (slightly) by Will Clinger (Nov 2007)
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs unicode)
|
||||
(rnrs sorting)
|
||||
(rnrs hashtables)
|
||||
(rnrs io simple))
|
||||
|
||||
(define (fill input-file h)
|
||||
(let ((p (open-input-file input-file)))
|
||||
(define (put ls)
|
||||
(hashtable-update! h
|
||||
(string->symbol
|
||||
(list->string
|
||||
(reverse ls)))
|
||||
(lambda (x) (+ x 1))
|
||||
0))
|
||||
(define (alpha ls)
|
||||
(let ((c (read-char p)))
|
||||
(cond
|
||||
((eof-object? c)
|
||||
(put ls))
|
||||
((char-alphabetic? c)
|
||||
(alpha (cons (char-downcase c) ls)))
|
||||
(else (put ls) (non-alpha)))))
|
||||
(define (non-alpha)
|
||||
(let ((c (read-char p)))
|
||||
(cond
|
||||
((eof-object? c) (values))
|
||||
((char-alphabetic? c)
|
||||
(alpha (list (char-downcase c))))
|
||||
(else (non-alpha)))))
|
||||
(non-alpha)
|
||||
(close-input-port p)))
|
||||
|
||||
(define (list-head ls n)
|
||||
(cond
|
||||
((or (zero? n) (null? ls)) '())
|
||||
(else (cons (car ls) (list-head (cdr ls) (- n 1))))))
|
||||
|
||||
(define (go input-file)
|
||||
(let ((h (make-eq-hashtable)))
|
||||
(fill input-file h)
|
||||
(let-values (((keys vals) (hashtable-entries h)))
|
||||
(let ((ls (map cons
|
||||
(vector->list keys)
|
||||
(vector->list vals))))
|
||||
(list-head
|
||||
(list-sort (lambda (a b) (> (cdr a) (cdr b))) ls)
|
||||
10)))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 input1)
|
||||
(name "bibfreq"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
1
|
||||
(lambda () (go (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
;;; find the most frequently referenced word in the bible.
|
||||
;;; aziz ghuloum (Nov 2007)
|
||||
;;; modified by Will Clinger (Nov 2007)
|
||||
;;; to use symbol-hash instead of eq? hashtables
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs unicode)
|
||||
(rnrs sorting)
|
||||
(rnrs hashtables)
|
||||
(rnrs io simple))
|
||||
|
||||
(define (fill input-file h)
|
||||
(let ((p (open-input-file input-file)))
|
||||
(define (put ls)
|
||||
(hashtable-update! h
|
||||
(string->symbol
|
||||
(list->string
|
||||
(reverse ls)))
|
||||
(lambda (x) (+ x 1))
|
||||
0))
|
||||
(define (alpha ls)
|
||||
(let ((c (read-char p)))
|
||||
(cond
|
||||
((eof-object? c)
|
||||
(put ls))
|
||||
((char-alphabetic? c)
|
||||
(alpha (cons (char-downcase c) ls)))
|
||||
(else (put ls) (non-alpha)))))
|
||||
(define (non-alpha)
|
||||
(let ((c (read-char p)))
|
||||
(cond
|
||||
((eof-object? c) (values))
|
||||
((char-alphabetic? c)
|
||||
(alpha (list (char-downcase c))))
|
||||
(else (non-alpha)))))
|
||||
(non-alpha)
|
||||
(close-input-port p)))
|
||||
|
||||
(define (list-head ls n)
|
||||
(cond
|
||||
((or (zero? n) (null? ls)) '())
|
||||
(else (cons (car ls) (list-head (cdr ls) (- n 1))))))
|
||||
|
||||
(define (go input-file)
|
||||
(let ((h (make-hashtable symbol-hash eq?)))
|
||||
(fill input-file h)
|
||||
(let-values (((keys vals) (hashtable-entries h)))
|
||||
(let ((ls (map cons
|
||||
(vector->list keys)
|
||||
(vector->list vals))))
|
||||
(list-head
|
||||
(list-sort (lambda (a b) (> (cdr a) (cdr b))) ls)
|
||||
10)))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 input1)
|
||||
(name "bibfreq2"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
1
|
||||
(lambda () (go (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
|
@ -0,0 +1,207 @@
|
|||
;;; 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))
|
||||
|
||||
(define (lookup key table)
|
||||
(let loop ((x table))
|
||||
(if (null? x)
|
||||
#f
|
||||
(let ((pair (car x)))
|
||||
(if (eq? (car pair) key)
|
||||
pair
|
||||
(loop (cdr x)))))))
|
||||
|
||||
(define properties '())
|
||||
|
||||
(define (get key1 key2)
|
||||
(let ((x (lookup key1 properties)))
|
||||
(if x
|
||||
(let ((y (lookup key2 (cdr x))))
|
||||
(if y
|
||||
(cdr y)
|
||||
#f))
|
||||
#f)))
|
||||
|
||||
(define (put key1 key2 val)
|
||||
(let ((x (lookup key1 properties)))
|
||||
(if x
|
||||
(let ((y (lookup key2 (cdr x))))
|
||||
(if y
|
||||
(set-cdr! y val)
|
||||
(set-cdr! x (cons (cons key2 val) (cdr x)))))
|
||||
(set! properties
|
||||
(cons (list key1 (cons key2 val)) properties)))))
|
||||
|
||||
(define *current-gensym* 0)
|
||||
|
||||
(define (generate-symbol)
|
||||
(set! *current-gensym* (+ *current-gensym* 1))
|
||||
(string->symbol (number->string *current-gensym*)))
|
||||
|
||||
(define (append-to-tail! x y)
|
||||
(if (null? x)
|
||||
y
|
||||
(do ((a x b)
|
||||
(b (cdr x) (cdr b)))
|
||||
((null? b)
|
||||
(set-cdr! a y)
|
||||
x))))
|
||||
|
||||
(define (tree-copy x)
|
||||
(if (not (pair? x))
|
||||
x
|
||||
(cons (tree-copy (car x))
|
||||
(tree-copy (cdr x)))))
|
||||
|
||||
;;; n is # of symbols
|
||||
;;; m is maximum amount of stuff on the plist
|
||||
;;; npats is the number of basic patterns on the unit
|
||||
;;; ipats is the instantiated copies of the patterns
|
||||
|
||||
(define *rand* 21)
|
||||
|
||||
(define (init n m npats ipats)
|
||||
(let ((ipats (tree-copy ipats)))
|
||||
(do ((p ipats (cdr p)))
|
||||
((null? (cdr p)) (set-cdr! p ipats)))
|
||||
(do ((n n (- n 1))
|
||||
(i m (cond ((zero? i) m)
|
||||
(else (- i 1))))
|
||||
(name (generate-symbol) (generate-symbol))
|
||||
(a '()))
|
||||
((= n 0) a)
|
||||
(set! a (cons name a))
|
||||
(do ((i i (- i 1)))
|
||||
((zero? i))
|
||||
(put name (generate-symbol) #f))
|
||||
(put name
|
||||
'pattern
|
||||
(do ((i npats (- i 1))
|
||||
(ipats ipats (cdr ipats))
|
||||
(a '()))
|
||||
((zero? i) a)
|
||||
(set! a (cons (car ipats) a))))
|
||||
(do ((j (- m i) (- j 1)))
|
||||
((zero? j))
|
||||
(put name (generate-symbol) #f)))))
|
||||
|
||||
(define (browse-random)
|
||||
(set! *rand* (mod (* *rand* 17) 251))
|
||||
*rand*)
|
||||
|
||||
(define (randomize l)
|
||||
(do ((a '()))
|
||||
((null? l) a)
|
||||
(let ((n (mod (browse-random) (length l))))
|
||||
(cond ((zero? n)
|
||||
(set! a (cons (car l) a))
|
||||
(set! l (cdr l))
|
||||
l)
|
||||
(else
|
||||
(do ((n n (- n 1))
|
||||
(x l (cdr x)))
|
||||
((= n 1)
|
||||
(set! a (cons (cadr x) a))
|
||||
(set-cdr! x (cddr x))
|
||||
x)))))))
|
||||
|
||||
(define (my-match pat dat alist)
|
||||
(cond ((null? pat)
|
||||
(null? dat))
|
||||
((null? dat) '())
|
||||
((or (eq? (car pat) '?)
|
||||
(eq? (car pat)
|
||||
(car dat)))
|
||||
(my-match (cdr pat) (cdr dat) alist))
|
||||
((eq? (car pat) '*)
|
||||
(or (my-match (cdr pat) dat alist)
|
||||
(my-match (cdr pat) (cdr dat) alist)
|
||||
(my-match pat (cdr dat) alist)))
|
||||
(else (cond ((not (pair? (car pat)))
|
||||
(cond ((eq? (string-ref (symbol->string (car pat)) 0)
|
||||
#\?)
|
||||
(let ((val (assq (car pat) alist)))
|
||||
(cond (val (my-match (cons (cdr val)
|
||||
(cdr pat))
|
||||
dat alist))
|
||||
(else (my-match (cdr pat)
|
||||
(cdr dat)
|
||||
(cons (cons (car pat)
|
||||
(car dat))
|
||||
alist))))))
|
||||
((eq? (string-ref (symbol->string (car pat)) 0)
|
||||
#\*)
|
||||
(let ((val (assq (car pat) alist)))
|
||||
(cond (val (my-match (append (cdr val)
|
||||
(cdr pat))
|
||||
dat alist))
|
||||
(else
|
||||
(do ((l '()
|
||||
(append-to-tail!
|
||||
l
|
||||
(cons (if (null? d)
|
||||
'()
|
||||
(car d))
|
||||
'())))
|
||||
(e (cons '() dat) (cdr e))
|
||||
(d dat (if (null? d) '() (cdr d))))
|
||||
((or (null? e)
|
||||
(my-match (cdr pat)
|
||||
d
|
||||
(cons
|
||||
(cons (car pat) l)
|
||||
alist)))
|
||||
(if (null? e) #f #t)))))))
|
||||
|
||||
;; fix suggested by Manuel Serrano
|
||||
;; (cond did not have an else clause);
|
||||
;; this changes the run time quite a bit
|
||||
|
||||
(else #f)))
|
||||
(else (and
|
||||
(pair? (car dat))
|
||||
(my-match (car pat)
|
||||
(car dat) alist)
|
||||
(my-match (cdr pat)
|
||||
(cdr dat) alist)))))))
|
||||
|
||||
(define database
|
||||
(randomize
|
||||
(init 100 10 4 '((a a a b b b b a a a a a b b a a a)
|
||||
(a a b b b b a a
|
||||
(a a)(b b))
|
||||
(a a a b (b a) b a b a)))))
|
||||
|
||||
(define (browse pats)
|
||||
(investigate
|
||||
database
|
||||
pats)
|
||||
database)
|
||||
|
||||
(define (investigate units pats)
|
||||
(do ((units units (cdr units)))
|
||||
((null? units))
|
||||
(do ((pats pats (cdr pats)))
|
||||
((null? pats))
|
||||
(do ((p (get (car units) 'pattern)
|
||||
(cdr p)))
|
||||
((null? p))
|
||||
(my-match (car pats) (car p) '())))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 "")
|
||||
(name "browse"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (browse (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
|
@ -0,0 +1,599 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; Copyright 2007 William D Clinger.
|
||||
;
|
||||
; Permission to copy this software, in whole or in part, to use this
|
||||
; software for any lawful purpose, and to redistribute this software
|
||||
; is granted subject to the restriction that all copies made of this
|
||||
; software must include this copyright notice in full.
|
||||
;
|
||||
; I also request that you send me a copy of any improvements that you
|
||||
; make to this software so that they may be incorporated within it to
|
||||
; the benefit of the Scheme community.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; Tests of string <-> bytevector conversions.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs unicode)
|
||||
(rnrs bytevectors)
|
||||
(rnrs control)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-strings))
|
||||
|
||||
; Crude test rig, just for benchmarking.
|
||||
|
||||
(define failed-tests '())
|
||||
|
||||
(define (test name actual expected)
|
||||
(if (not (equal? actual expected))
|
||||
(begin (display "******** FAILED TEST ******** ")
|
||||
(display name)
|
||||
(newline)
|
||||
(set! failed-tests (cons name failed-tests)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; The R6RS doesn't specify exactly how many replacement
|
||||
; characters get generated by an encoding or decoding error,
|
||||
; so the results of some tests are compared by treating any
|
||||
; sequence of consecutive replacement characters the same as
|
||||
; a single replacement character.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (string~? s1 s2)
|
||||
(define (replacement? c)
|
||||
(char=? c #\xfffd))
|
||||
(define (canonicalized s)
|
||||
(let loop ((rchars (reverse (string->list s)))
|
||||
(cchars '()))
|
||||
(cond ((or (null? rchars) (null? (cdr rchars)))
|
||||
(list->string cchars))
|
||||
((and (replacement? (car rchars))
|
||||
(replacement? (cadr rchars)))
|
||||
(loop (cdr rchars) cchars))
|
||||
(else
|
||||
(loop (cdr rchars) (cons (car rchars) cchars))))))
|
||||
(string=? (canonicalized s1) (canonicalized s2)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; Basic sanity tests, followed by stress tests on random inputs.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (string-bytevector-tests
|
||||
*random-stress-tests* *random-stress-test-max-size*)
|
||||
|
||||
(define (test-roundtrip bvec tostring tobvec)
|
||||
(let* ((s1 (tostring bvec))
|
||||
(b2 (tobvec s1))
|
||||
(s2 (tostring b2)))
|
||||
(test "round trip of string conversion" (string=? s1 s2) #t)))
|
||||
|
||||
; This random number generator doesn't have to be good.
|
||||
; It just has to be fast.
|
||||
|
||||
(define random
|
||||
(letrec ((random14
|
||||
(lambda (n)
|
||||
(set! x (mod (+ (* a x) c) (+ m 1)))
|
||||
(mod (div x 8) n)))
|
||||
(a 701)
|
||||
(x 1)
|
||||
(c 743483)
|
||||
(m 524287)
|
||||
(loop
|
||||
(lambda (q r n)
|
||||
(if (zero? q)
|
||||
(mod r n)
|
||||
(loop (div q 16384)
|
||||
(+ (* 16384 r) (random14 16384))
|
||||
n)))))
|
||||
(lambda (n)
|
||||
(if (< n 16384)
|
||||
(random14 n)
|
||||
(loop (div n 16384) (random14 16384) n)))))
|
||||
|
||||
; Returns a random bytevector of length up to n.
|
||||
|
||||
(define (random-bytevector n)
|
||||
(let* ((n (random n))
|
||||
(bv (make-bytevector n)))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i n) bv)
|
||||
(bytevector-u8-set! bv i (random 256)))))
|
||||
|
||||
; Returns a random bytevector of even length up to n.
|
||||
|
||||
(define (random-bytevector2 n)
|
||||
(let* ((n (random n))
|
||||
(n (if (odd? n) (+ n 1) n))
|
||||
(bv (make-bytevector n)))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i n) bv)
|
||||
(bytevector-u8-set! bv i (random 256)))))
|
||||
|
||||
; Returns a random bytevector of multiple-of-4 length up to n.
|
||||
|
||||
(define (random-bytevector4 n)
|
||||
(let* ((n (random n))
|
||||
(n (* 4 (round (/ n 4))))
|
||||
(bv (make-bytevector n)))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i n) bv)
|
||||
(bytevector-u8-set! bv i (random 256)))))
|
||||
|
||||
(test "utf-8, BMP"
|
||||
(bytevector=? (string->utf8 "k\x007f;\x0080;\x07ff;\x0800;\xffff;")
|
||||
'#vu8(#x6b
|
||||
#x7f
|
||||
#b11000010 #b10000000
|
||||
#b11011111 #b10111111
|
||||
#b11100000 #b10100000 #b10000000
|
||||
#b11101111 #b10111111 #b10111111))
|
||||
#t)
|
||||
|
||||
(test "utf-8, supplemental"
|
||||
(bytevector=? (string->utf8 "\x010000;\x10ffff;")
|
||||
'#vu8(#b11110000 #b10010000 #b10000000 #b10000000
|
||||
#b11110100 #b10001111 #b10111111 #b10111111))
|
||||
#t)
|
||||
|
||||
(test "utf-8, errors 1"
|
||||
(string~? (utf8->string '#vu8(#x61 ; a
|
||||
#xc0 #x62 ; ?b
|
||||
#xc1 #x63 ; ?c
|
||||
#xc2 #x64 ; ?d
|
||||
#x80 #x65 ; ?e
|
||||
#xc0 #xc0 #x66 ; ??f
|
||||
#xe0 #x67 ; ?g
|
||||
))
|
||||
"a\xfffd;b\xfffd;c\xfffd;d\xfffd;e\xfffd;\xfffd;f\xfffd;g")
|
||||
#t)
|
||||
|
||||
(test "utf-8, errors 2"
|
||||
(string~? (utf8->string '#vu8(#xe0 #x80 #x80 #x68 ; ???h
|
||||
#xe0 #xc0 #x80 #x69 ; ???i
|
||||
#xf0 #x6a ; ?j
|
||||
))
|
||||
"\xfffd;\xfffd;\xfffd;h\xfffd;\xfffd;\xfffd;i\xfffd;j")
|
||||
#t)
|
||||
|
||||
(test "utf-8, errors 3"
|
||||
(string~? (utf8->string '#vu8(#x61 ; a
|
||||
#xf0 #x80 #x80 #x80 #x62 ; ????b
|
||||
#xf0 #x90 #x80 #x80 #x63 ; .c
|
||||
))
|
||||
"a\xfffd;\xfffd;\xfffd;\xfffd;b\x10000;c")
|
||||
#t)
|
||||
|
||||
(test "utf-8, errors 4"
|
||||
(string~? (utf8->string '#vu8(#x61 ; a
|
||||
#xf0 #xbf #xbf #xbf #x64 ; .d
|
||||
#xf0 #xbf #xbf #x65 ; ?e
|
||||
#xf0 #xbf #x66 ; ?f
|
||||
))
|
||||
"a\x3ffff;d\xfffd;e\xfffd;f")
|
||||
#t)
|
||||
|
||||
(test "utf-8, errors 5"
|
||||
(string~? (utf8->string '#vu8(#x61 ; a
|
||||
#xf4 #x8f #xbf #xbf #x62 ; .b
|
||||
#xf4 #x90 #x80 #x80 #x63 ; ????c
|
||||
))
|
||||
|
||||
"a\x10ffff;b\xfffd;\xfffd;\xfffd;\xfffd;c")
|
||||
#t)
|
||||
|
||||
(test "utf-8, errors 6"
|
||||
(string~? (utf8->string '#vu8(#x61 ; a
|
||||
#xf5 #x80 #x80 #x80 #x64 ; ????d
|
||||
))
|
||||
|
||||
"a\xfffd;\xfffd;\xfffd;\xfffd;d")
|
||||
#t)
|
||||
|
||||
; ignores BOM signature
|
||||
; Officially, there is no BOM signature for UTF-8,
|
||||
; so this test is commented out.
|
||||
|
||||
#;(test "utf-8, BOM"
|
||||
(string=? (utf8->string '#vu8(#xef #xbb #xbf #x61 #x62 #x63 #x64))
|
||||
"abcd")
|
||||
#t)
|
||||
|
||||
(test-roundtrip (random-bytevector 10) utf8->string string->utf8)
|
||||
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i *random-stress-tests*))
|
||||
(test-roundtrip (random-bytevector *random-stress-test-max-size*)
|
||||
utf8->string string->utf8))
|
||||
|
||||
(test "utf-16, BMP"
|
||||
(bytevector=? (string->utf16 "k\x007f;\x0080;\x07ff;\x0800;\xffff;")
|
||||
'#vu8(#x00 #x6b
|
||||
#x00 #x7f
|
||||
#x00 #x80
|
||||
#x07 #xff
|
||||
#x08 #x00
|
||||
#xff #xff))
|
||||
#t)
|
||||
|
||||
(test "utf-16le, BMP"
|
||||
(bytevector=? (string->utf16 "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
|
||||
'little)
|
||||
'#vu8(#x6b #x00
|
||||
#x7f #x00
|
||||
#x80 #x00
|
||||
#xff #x07
|
||||
#x00 #x08
|
||||
#xff #xff))
|
||||
#t)
|
||||
|
||||
(test "utf-16, supplemental"
|
||||
(bytevector=? (string->utf16 "\x010000;\xfdcba;\x10ffff;")
|
||||
'#vu8(#xd8 #x00 #xdc #x00
|
||||
#xdb #xb7 #xdc #xba
|
||||
#xdb #xff #xdf #xff))
|
||||
#t)
|
||||
|
||||
(test "utf-16le, supplemental"
|
||||
(bytevector=? (string->utf16 "\x010000;\xfdcba;\x10ffff;" 'little)
|
||||
'#vu8(#x00 #xd8 #x00 #xdc
|
||||
#xb7 #xdb #xba #xdc
|
||||
#xff #xdb #xff #xdf))
|
||||
#t)
|
||||
|
||||
(test "utf-16be"
|
||||
(bytevector=? (string->utf16 "ab\x010000;\xfdcba;\x10ffff;cd")
|
||||
(string->utf16 "ab\x010000;\xfdcba;\x10ffff;cd" 'big))
|
||||
#t)
|
||||
|
||||
(test "utf-16, errors 1"
|
||||
(string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
|
||||
(utf16->string
|
||||
'#vu8(#x00 #x6b
|
||||
#x00 #x7f
|
||||
#x00 #x80
|
||||
#x07 #xff
|
||||
#x08 #x00
|
||||
#xff #xff)
|
||||
'big))
|
||||
#t)
|
||||
|
||||
(test "utf-16, errors 2"
|
||||
(string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
|
||||
(utf16->string
|
||||
'#vu8(#x00 #x6b
|
||||
#x00 #x7f
|
||||
#x00 #x80
|
||||
#x07 #xff
|
||||
#x08 #x00
|
||||
#xff #xff)
|
||||
'big #t))
|
||||
#t)
|
||||
|
||||
(test "utf-16, errors 3"
|
||||
(string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
|
||||
(utf16->string
|
||||
'#vu8(#xfe #xff ; big-endian BOM
|
||||
#x00 #x6b
|
||||
#x00 #x7f
|
||||
#x00 #x80
|
||||
#x07 #xff
|
||||
#x08 #x00
|
||||
#xff #xff)
|
||||
'big))
|
||||
#t)
|
||||
|
||||
(test "utf-16, errors 4"
|
||||
(string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
|
||||
(utf16->string
|
||||
'#vu8(#x6b #x00
|
||||
#x7f #x00
|
||||
#x80 #x00
|
||||
#xff #x07
|
||||
#x00 #x08
|
||||
#xff #xff)
|
||||
'little #t))
|
||||
#t)
|
||||
|
||||
(test "utf-16, errors 5"
|
||||
(string~? "k\x007f;\x0080;\x07ff;\x0800;\xffff;"
|
||||
(utf16->string
|
||||
'#vu8(#xff #xfe ; little-endian BOM
|
||||
#x6b #x00
|
||||
#x7f #x00
|
||||
#x80 #x00
|
||||
#xff #x07
|
||||
#x00 #x08
|
||||
#xff #xff)
|
||||
'big))
|
||||
#t)
|
||||
|
||||
(let ((tostring (lambda (bv) (utf16->string bv 'big)))
|
||||
(tostring-big (lambda (bv) (utf16->string bv 'big #t)))
|
||||
(tostring-little (lambda (bv) (utf16->string bv 'little #t)))
|
||||
(tobvec string->utf16)
|
||||
(tobvec-big (lambda (s) (string->utf16 s 'big)))
|
||||
(tobvec-little (lambda (s) (string->utf16 s 'little))))
|
||||
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i *random-stress-tests*))
|
||||
(test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
|
||||
tostring tobvec)
|
||||
(test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
|
||||
tostring-big tobvec-big)
|
||||
(test-roundtrip (random-bytevector2 *random-stress-test-max-size*)
|
||||
tostring-little tobvec-little)))
|
||||
|
||||
(test "utf-32"
|
||||
(bytevector=? (string->utf32 "abc")
|
||||
'#vu8(#x00 #x00 #x00 #x61
|
||||
#x00 #x00 #x00 #x62
|
||||
#x00 #x00 #x00 #x63))
|
||||
#t)
|
||||
|
||||
(test "utf-32be"
|
||||
(bytevector=? (string->utf32 "abc" 'big)
|
||||
'#vu8(#x00 #x00 #x00 #x61
|
||||
#x00 #x00 #x00 #x62
|
||||
#x00 #x00 #x00 #x63))
|
||||
#t)
|
||||
|
||||
(test "utf-32le"
|
||||
(bytevector=? (string->utf32 "abc" 'little)
|
||||
'#vu8(#x61 #x00 #x00 #x00
|
||||
#x62 #x00 #x00 #x00
|
||||
#x63 #x00 #x00 #x00))
|
||||
#t)
|
||||
|
||||
(test "utf-32, errors 1"
|
||||
(string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
|
||||
(utf32->string
|
||||
'#vu8(#x00 #x00 #x00 #x61
|
||||
#x00 #x00 #xd9 #x00
|
||||
#x00 #x00 #x00 #x62
|
||||
#x00 #x00 #xdd #xab
|
||||
#x00 #x00 #x00 #x63
|
||||
#x00 #x11 #x00 #x00
|
||||
#x00 #x00 #x00 #x64
|
||||
#x01 #x00 #x00 #x65
|
||||
#x00 #x00 #x00 #x65)
|
||||
'big))
|
||||
#t)
|
||||
|
||||
(test "utf-32, errors 2"
|
||||
(string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
|
||||
(utf32->string
|
||||
'#vu8(#x00 #x00 #x00 #x61
|
||||
#x00 #x00 #xd9 #x00
|
||||
#x00 #x00 #x00 #x62
|
||||
#x00 #x00 #xdd #xab
|
||||
#x00 #x00 #x00 #x63
|
||||
#x00 #x11 #x00 #x00
|
||||
#x00 #x00 #x00 #x64
|
||||
#x01 #x00 #x00 #x65
|
||||
#x00 #x00 #x00 #x65)
|
||||
'big #t))
|
||||
#t)
|
||||
|
||||
(test "utf-32, errors 3"
|
||||
(string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
|
||||
(utf32->string
|
||||
'#vu8(#x00 #x00 #xfe #xff ; big-endian BOM
|
||||
#x00 #x00 #x00 #x61
|
||||
#x00 #x00 #xd9 #x00
|
||||
#x00 #x00 #x00 #x62
|
||||
#x00 #x00 #xdd #xab
|
||||
#x00 #x00 #x00 #x63
|
||||
#x00 #x11 #x00 #x00
|
||||
#x00 #x00 #x00 #x64
|
||||
#x01 #x00 #x00 #x65
|
||||
#x00 #x00 #x00 #x65)
|
||||
'big))
|
||||
#t)
|
||||
|
||||
(test "utf-32, errors 4"
|
||||
(string~? "\xfeff;a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
|
||||
(utf32->string
|
||||
'#vu8(#x00 #x00 #xfe #xff ; big-endian BOM
|
||||
#x00 #x00 #x00 #x61
|
||||
#x00 #x00 #xd9 #x00
|
||||
#x00 #x00 #x00 #x62
|
||||
#x00 #x00 #xdd #xab
|
||||
#x00 #x00 #x00 #x63
|
||||
#x00 #x11 #x00 #x00
|
||||
#x00 #x00 #x00 #x64
|
||||
#x01 #x00 #x00 #x65
|
||||
#x00 #x00 #x00 #x65)
|
||||
'big #t))
|
||||
#t)
|
||||
|
||||
(test "utf-32, errors 5"
|
||||
(string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
|
||||
(utf32->string
|
||||
'#vu8(#x61 #x00 #x00 #x00
|
||||
#x00 #xd9 #x00 #x00
|
||||
#x62 #x00 #x00 #x00
|
||||
#xab #xdd #x00 #x00
|
||||
#x63 #x00 #x00 #x00
|
||||
#x00 #x00 #x11 #x00
|
||||
#x64 #x00 #x00 #x00
|
||||
#x65 #x00 #x00 #x01
|
||||
#x65 #x00 #x00 #x00)
|
||||
'little #t))
|
||||
#t)
|
||||
|
||||
(test "utf-32, errors 6"
|
||||
(string~? "a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
|
||||
(utf32->string
|
||||
'#vu8(#xff #xfe #x00 #x00 ; little-endian BOM
|
||||
#x61 #x00 #x00 #x00
|
||||
#x00 #xd9 #x00 #x00
|
||||
#x62 #x00 #x00 #x00
|
||||
#xab #xdd #x00 #x00
|
||||
#x63 #x00 #x00 #x00
|
||||
#x00 #x00 #x11 #x00
|
||||
#x64 #x00 #x00 #x00
|
||||
#x65 #x00 #x00 #x01
|
||||
#x65 #x00 #x00 #x00)
|
||||
'big))
|
||||
#t)
|
||||
|
||||
(test "utf-32, errors 7"
|
||||
(string~? "\xfeff;a\xfffd;b\xfffd;c\xfffd;d\xfffd;e"
|
||||
(utf32->string
|
||||
'#vu8(#xff #xfe #x00 #x00 ; little-endian BOM
|
||||
#x61 #x00 #x00 #x00
|
||||
#x00 #xd9 #x00 #x00
|
||||
#x62 #x00 #x00 #x00
|
||||
#xab #xdd #x00 #x00
|
||||
#x63 #x00 #x00 #x00
|
||||
#x00 #x00 #x11 #x00
|
||||
#x64 #x00 #x00 #x00
|
||||
#x65 #x00 #x00 #x01
|
||||
#x65 #x00 #x00 #x00)
|
||||
'little #t))
|
||||
#t)
|
||||
|
||||
(let ((tostring (lambda (bv) (utf32->string bv 'big)))
|
||||
(tostring-big (lambda (bv) (utf32->string bv 'big #t)))
|
||||
(tostring-little (lambda (bv) (utf32->string bv 'little #t)))
|
||||
(tobvec string->utf32)
|
||||
(tobvec-big (lambda (s) (string->utf32 s 'big)))
|
||||
(tobvec-little (lambda (s) (string->utf32 s 'little))))
|
||||
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i *random-stress-tests*))
|
||||
(test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
|
||||
tostring tobvec)
|
||||
(test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
|
||||
tostring-big tobvec-big)
|
||||
(test-roundtrip (random-bytevector4 *random-stress-test-max-size*)
|
||||
tostring-little tobvec-little)))
|
||||
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; Exhaustive tests.
|
||||
;
|
||||
; Tests string <-> bytevector conversion on strings
|
||||
; that contain every Unicode scalar value.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (exhaustive-string-bytevector-tests)
|
||||
|
||||
; Tests throughout an inclusive range.
|
||||
|
||||
(define (test-char-range lo hi tostring tobytevector)
|
||||
(let* ((n (+ 1 (- hi lo)))
|
||||
(s (make-string n))
|
||||
(replacement-character (integer->char #xfffd)))
|
||||
(do ((i lo (+ i 1)))
|
||||
((> i hi))
|
||||
(let ((c (if (or (<= 0 i #xd7ff)
|
||||
(<= #xe000 i #x10ffff))
|
||||
(integer->char i)
|
||||
replacement-character)))
|
||||
(string-set! s (- i lo) c)))
|
||||
(test "test of long string conversion"
|
||||
(string=? (tostring (tobytevector s)) s) #t)))
|
||||
|
||||
(define (test-exhaustively name tostring tobytevector)
|
||||
;(display "Testing ")
|
||||
;(display name)
|
||||
;(display " conversions...")
|
||||
;(newline)
|
||||
(test-char-range 0 #xffff tostring tobytevector)
|
||||
(test-char-range #x10000 #x1ffff tostring tobytevector)
|
||||
(test-char-range #x20000 #x2ffff tostring tobytevector)
|
||||
(test-char-range #x30000 #x3ffff tostring tobytevector)
|
||||
(test-char-range #x40000 #x4ffff tostring tobytevector)
|
||||
(test-char-range #x50000 #x5ffff tostring tobytevector)
|
||||
(test-char-range #x60000 #x6ffff tostring tobytevector)
|
||||
(test-char-range #x70000 #x7ffff tostring tobytevector)
|
||||
(test-char-range #x80000 #x8ffff tostring tobytevector)
|
||||
(test-char-range #x90000 #x9ffff tostring tobytevector)
|
||||
(test-char-range #xa0000 #xaffff tostring tobytevector)
|
||||
(test-char-range #xb0000 #xbffff tostring tobytevector)
|
||||
(test-char-range #xc0000 #xcffff tostring tobytevector)
|
||||
(test-char-range #xd0000 #xdffff tostring tobytevector)
|
||||
(test-char-range #xe0000 #xeffff tostring tobytevector)
|
||||
(test-char-range #xf0000 #xfffff tostring tobytevector)
|
||||
(test-char-range #x100000 #x10ffff tostring tobytevector))
|
||||
|
||||
; Feel free to replace this with your favorite timing macro.
|
||||
|
||||
(define (timeit x) x)
|
||||
|
||||
(timeit (test-exhaustively "UTF-8" utf8->string string->utf8))
|
||||
|
||||
; NOTE: An unfortunate misunderstanding led to a late deletion
|
||||
; of single-argument utf16->string from the R6RS. To get the
|
||||
; correct effect of single-argument utf16->string, you have to
|
||||
; use two arguments, as below.
|
||||
;
|
||||
;(timeit (test-exhaustively "UTF-16" utf16->string string->utf16))
|
||||
|
||||
(timeit (test-exhaustively "UTF-16"
|
||||
(lambda (bv) (utf16->string bv 'big))
|
||||
string->utf16))
|
||||
|
||||
; NOTE: To get the correct effect of two-argument utf16->string,
|
||||
; you have to use three arguments, as below.
|
||||
|
||||
(timeit (test-exhaustively "UTF-16BE"
|
||||
(lambda (bv) (utf16->string bv 'big #t))
|
||||
(lambda (s) (string->utf16 s 'big))))
|
||||
|
||||
(timeit (test-exhaustively "UTF-16LE"
|
||||
(lambda (bv) (utf16->string bv 'little #t))
|
||||
(lambda (s) (string->utf16 s 'little))))
|
||||
|
||||
; NOTE: An unfortunate misunderstanding led to a late deletion
|
||||
; of single-argument utf32->string from the R6RS. To get the
|
||||
; correct effect of single-argument utf32->string, you have to
|
||||
; use two arguments, as below.
|
||||
;
|
||||
;(timeit (test-exhaustively "UTF-32" utf32->string string->utf32))
|
||||
|
||||
(timeit (test-exhaustively "UTF-32"
|
||||
(lambda (bv) (utf32->string bv 'big))
|
||||
string->utf32))
|
||||
|
||||
; NOTE: To get the correct effect of two-argument utf32->string,
|
||||
; you have to use three arguments, as below.
|
||||
|
||||
(timeit (test-exhaustively "UTF-32BE"
|
||||
(lambda (bv) (utf32->string bv 'big #t))
|
||||
(lambda (s) (string->utf32 s 'big))))
|
||||
|
||||
(timeit (test-exhaustively "UTF-32LE"
|
||||
(lambda (bv) (utf32->string bv 'little #t))
|
||||
(lambda (s) (string->utf32 s 'little)))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(input2 (read))
|
||||
(output (read))
|
||||
(s3 (number->string count))
|
||||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "bv2string"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3)
|
||||
count
|
||||
(lambda ()
|
||||
(string-bytevector-tests (hide count count) (hide count input1))
|
||||
(exhaustive-string-bytevector-tests)
|
||||
(length failed-tests))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
;;; 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))
|
||||
|
||||
(define (catport in out)
|
||||
(let ((x (read-char in)))
|
||||
(if (not (eof-object? x))
|
||||
(begin
|
||||
(write-char x out)
|
||||
(catport in out)))))
|
||||
|
||||
(define (go input-file output-file)
|
||||
(if (file-exists? output-file)
|
||||
(delete-file output-file))
|
||||
(call-with-input-file
|
||||
input-file
|
||||
(lambda (in)
|
||||
(call-with-output-file
|
||||
output-file
|
||||
(lambda (out)
|
||||
(catport in out))))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(input2 (read))
|
||||
(output (read))
|
||||
(s3 (number->string count))
|
||||
(s2 input2)
|
||||
(s1 input1)
|
||||
(name "cat"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s3)
|
||||
count
|
||||
(lambda () (go (hide count input1) (hide count input2)))
|
||||
(lambda (result) #t))))
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
;;; CAT -- One of the Kernighan and Van Wyk benchmarks.
|
||||
;;; Rewritten by Will Clinger into more idiomatic Scheme
|
||||
;;; and to use UTF-8 transcoding.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io ports)
|
||||
(rnrs io simple)
|
||||
(rnrs files))
|
||||
|
||||
(define (catport in out)
|
||||
(let ((x (get-char in)))
|
||||
(if (not (eof-object? x))
|
||||
(begin
|
||||
(put-char out x)
|
||||
(catport in out)))))
|
||||
|
||||
(define (go input-file output-file)
|
||||
(let ((t (make-transcoder (utf-8-codec))))
|
||||
(if (file-exists? output-file)
|
||||
(delete-file output-file))
|
||||
(call-with-port
|
||||
(open-file-input-port input-file (file-options) 'block t)
|
||||
(lambda (in)
|
||||
(call-with-port
|
||||
(open-file-output-port output-file (file-options) 'block t)
|
||||
(lambda (out)
|
||||
(catport in out)))))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(input2 (read))
|
||||
(output (read))
|
||||
(s3 (number->string count))
|
||||
(s2 input2)
|
||||
(s1 input1)
|
||||
(name "cat:utf-8"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s3)
|
||||
count
|
||||
(lambda () (go (hide count input1) (hide count input2)))
|
||||
(lambda (result) #t))))
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
;;; CAT -- One of the Kernighan and Van Wyk benchmarks.
|
||||
;;; Rewritten by Will Clinger into more idiomatic Scheme
|
||||
;;; and to use UTF-16 transcoding.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io ports)
|
||||
(rnrs io simple)
|
||||
(rnrs files))
|
||||
|
||||
(define (catport in out)
|
||||
(let ((x (get-char in)))
|
||||
(if (not (eof-object? x))
|
||||
(begin
|
||||
(put-char out x)
|
||||
(catport in out)))))
|
||||
|
||||
(define (go input-file output-file)
|
||||
(let ((t (make-transcoder (utf-16-codec))))
|
||||
(if (file-exists? output-file)
|
||||
(delete-file output-file))
|
||||
(call-with-port
|
||||
(open-file-input-port input-file (file-options) 'block t)
|
||||
(lambda (in)
|
||||
(call-with-port
|
||||
(open-file-output-port output-file (file-options) 'block t)
|
||||
(lambda (out)
|
||||
(catport in out)))))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(input2 (read))
|
||||
(output (read))
|
||||
(s3 (number->string count))
|
||||
(s2 input2)
|
||||
(s1 input1)
|
||||
(name "cat:utf-16"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s3)
|
||||
count
|
||||
(lambda () (go (hide count input1) (hide count input2)))
|
||||
(lambda (result) #t))))
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
|
||||
;;; The following code is appended to all benchmarks.
|
||||
|
||||
;;; Given an integer and an object, returns the object
|
||||
;;; without making it too easy for compilers to tell
|
||||
;;; the object will be returned.
|
||||
|
||||
(define (hide r x)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(values (vector values (lambda (x) x))
|
||||
(if (< r 100) 0 1)))
|
||||
(lambda (v i)
|
||||
((vector-ref v i) x))))
|
||||
|
||||
;;; Given the name of a benchmark,
|
||||
;;; the number of times it should be executed,
|
||||
;;; a thunk that runs the benchmark once,
|
||||
;;; and a unary predicate that is true of the
|
||||
;;; correct results the thunk may return,
|
||||
;;; runs the benchmark for the number of specified iterations.
|
||||
;;;
|
||||
;;; Implementation-specific versions of this procedure may
|
||||
;;; provide timings for the benchmark proper (without startup
|
||||
;;; and compile time).
|
||||
|
||||
(define (run-r6rs-benchmark name count thunk ok?)
|
||||
(display "Running ")
|
||||
(display name)
|
||||
(newline)
|
||||
(let loop ((i 0)
|
||||
(result (if #f #f)))
|
||||
(cond ((< i count)
|
||||
(loop (+ i 1) (thunk)))
|
||||
((ok? result)
|
||||
result)
|
||||
(else
|
||||
(display "ERROR: returned incorrect result: ")
|
||||
(write result)
|
||||
(newline)
|
||||
result))))
|
||||
|
||||
(main)
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,469 @@
|
|||
;;; CONFORM -- Type checker, written by Jim Miller.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs unicode)
|
||||
(rnrs lists)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs))
|
||||
|
||||
;;; Functional and unstable
|
||||
|
||||
(define (sort-list obj pred)
|
||||
|
||||
(define (loop l)
|
||||
(if (and (pair? l) (pair? (cdr l)))
|
||||
(split-list l '() '())
|
||||
l))
|
||||
|
||||
(define (split-list l one two)
|
||||
(if (pair? l)
|
||||
(split-list (cdr l) two (cons (car l) one))
|
||||
(merge (loop one) (loop two))))
|
||||
|
||||
(define (merge one two)
|
||||
(cond ((null? one) two)
|
||||
((pred (car two) (car one))
|
||||
(cons (car two)
|
||||
(merge (cdr two) one)))
|
||||
(else
|
||||
(cons (car one)
|
||||
(merge (cdr one) two)))))
|
||||
|
||||
(loop obj))
|
||||
|
||||
;; SET OPERATIONS
|
||||
; (representation as lists with distinct elements)
|
||||
|
||||
(define (adjoin element set)
|
||||
(if (memq element set) set (cons element set)))
|
||||
|
||||
(define (eliminate element set)
|
||||
(cond ((null? set) set)
|
||||
((eq? element (car set)) (cdr set))
|
||||
(else (cons (car set) (eliminate element (cdr set))))))
|
||||
|
||||
(define (intersect list1 list2)
|
||||
(let loop ((l list1))
|
||||
(cond ((null? l) '())
|
||||
((memq (car l) list2) (cons (car l) (loop (cdr l))))
|
||||
(else (loop (cdr l))))))
|
||||
|
||||
(define (union list1 list2)
|
||||
(if (null? list1)
|
||||
list2
|
||||
(union (cdr list1)
|
||||
(adjoin (car list1) list2))))
|
||||
|
||||
;; GRAPH NODES
|
||||
|
||||
(define make-internal-node vector)
|
||||
(define (internal-node-name node) (vector-ref node 0))
|
||||
(define (internal-node-green-edges node) (vector-ref node 1))
|
||||
(define (internal-node-red-edges node) (vector-ref node 2))
|
||||
(define (internal-node-blue-edges node) (vector-ref node 3))
|
||||
(define (set-internal-node-name! node name) (vector-set! node 0 name))
|
||||
(define (set-internal-node-green-edges! node edges) (vector-set! node 1 edges))
|
||||
(define (set-internal-node-red-edges! node edges) (vector-set! node 2 edges))
|
||||
(define (set-internal-node-blue-edges! node edges) (vector-set! node 3 edges))
|
||||
|
||||
(define (make-node name . blue-edges) ; User's constructor
|
||||
(let ((name (if (symbol? name) (symbol->string name) name))
|
||||
(blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges))))
|
||||
(make-internal-node name '() '() blue-edges)))
|
||||
|
||||
(define (copy-node node)
|
||||
(make-internal-node (name node) '() '() (blue-edges node)))
|
||||
|
||||
; Selectors
|
||||
|
||||
(define name internal-node-name)
|
||||
(define (make-edge-getter selector)
|
||||
(lambda (node)
|
||||
(if (or (none-node? node) (any-node? node))
|
||||
(error #f "Can't get edges from the ANY or NONE nodes")
|
||||
(selector node))))
|
||||
(define red-edges (make-edge-getter internal-node-red-edges))
|
||||
(define green-edges (make-edge-getter internal-node-green-edges))
|
||||
(define blue-edges (make-edge-getter internal-node-blue-edges))
|
||||
|
||||
; Mutators
|
||||
|
||||
(define (make-edge-setter mutator!)
|
||||
(lambda (node value)
|
||||
(cond ((any-node? node) (error #f "Can't set edges from the ANY node"))
|
||||
((none-node? node) 'OK)
|
||||
(else (mutator! node value)))))
|
||||
(define set-red-edges! (make-edge-setter set-internal-node-red-edges!))
|
||||
(define set-green-edges! (make-edge-setter set-internal-node-green-edges!))
|
||||
(define set-blue-edges! (make-edge-setter set-internal-node-blue-edges!))
|
||||
|
||||
;; BLUE EDGES
|
||||
|
||||
(define make-blue-edge vector)
|
||||
(define (blue-edge-operation edge) (vector-ref edge 0))
|
||||
(define (blue-edge-arg-node edge) (vector-ref edge 1))
|
||||
(define (blue-edge-res-node edge) (vector-ref edge 2))
|
||||
(define (set-blue-edge-operation! edge value) (vector-set! edge 0 value))
|
||||
(define (set-blue-edge-arg-node! edge value) (vector-set! edge 1 value))
|
||||
(define (set-blue-edge-res-node! edge value) (vector-set! edge 2 value))
|
||||
|
||||
; Selectors
|
||||
(define operation blue-edge-operation)
|
||||
(define arg-node blue-edge-arg-node)
|
||||
(define res-node blue-edge-res-node)
|
||||
|
||||
; Mutators
|
||||
(define set-arg-node! set-blue-edge-arg-node!)
|
||||
(define set-res-node! set-blue-edge-res-node!)
|
||||
|
||||
; Higher level operations on blue edges
|
||||
|
||||
(define (lookup-op op node)
|
||||
(let loop ((edges (blue-edges node)))
|
||||
(cond ((null? edges) '())
|
||||
((eq? op (operation (car edges))) (car edges))
|
||||
(else (loop (cdr edges))))))
|
||||
|
||||
(define (has-op? op node)
|
||||
(not (null? (lookup-op op node))))
|
||||
|
||||
;; GRAPHS
|
||||
|
||||
(define make-internal-graph vector)
|
||||
(define (internal-graph-nodes graph) (vector-ref graph 0))
|
||||
(define (internal-graph-already-met graph) (vector-ref graph 1))
|
||||
(define (internal-graph-already-joined graph) (vector-ref graph 2))
|
||||
(define (set-internal-graph-nodes! graph nodes) (vector-set! graph 0 nodes))
|
||||
|
||||
; Constructor
|
||||
|
||||
(define (make-graph . nodes)
|
||||
(make-internal-graph nodes (make-empty-table) (make-empty-table)))
|
||||
|
||||
; Selectors
|
||||
|
||||
(define graph-nodes internal-graph-nodes)
|
||||
(define already-met internal-graph-already-met)
|
||||
(define already-joined internal-graph-already-joined)
|
||||
|
||||
; Higher level functions on graphs
|
||||
|
||||
(define (add-graph-nodes! graph nodes)
|
||||
(set-internal-graph-nodes! graph (cons nodes (graph-nodes graph))))
|
||||
|
||||
(define (copy-graph g)
|
||||
(define (copy-list l) (vector->list (list->vector l)))
|
||||
(make-internal-graph
|
||||
(copy-list (graph-nodes g))
|
||||
(already-met g)
|
||||
(already-joined g)))
|
||||
|
||||
(define (clean-graph g)
|
||||
(define (clean-node node)
|
||||
(if (not (or (any-node? node) (none-node? node)))
|
||||
(begin
|
||||
(set-green-edges! node '())
|
||||
(set-red-edges! node '()))))
|
||||
(for-each clean-node (graph-nodes g))
|
||||
g)
|
||||
|
||||
(define (canonicalize-graph graph classes)
|
||||
(define (fix node)
|
||||
(define (fix-set object selector mutator)
|
||||
(mutator object
|
||||
(map (lambda (node)
|
||||
(find-canonical-representative node classes))
|
||||
(selector object))))
|
||||
(if (not (or (none-node? node) (any-node? node)))
|
||||
(begin
|
||||
(fix-set node green-edges set-green-edges!)
|
||||
(fix-set node red-edges set-red-edges!)
|
||||
(for-each
|
||||
(lambda (blue-edge)
|
||||
(set-arg-node! blue-edge
|
||||
(find-canonical-representative (arg-node blue-edge) classes))
|
||||
(set-res-node! blue-edge
|
||||
(find-canonical-representative (res-node blue-edge) classes)))
|
||||
(blue-edges node))))
|
||||
node)
|
||||
(define (fix-table table)
|
||||
(define (canonical? node) (eq? node (find-canonical-representative node classes)))
|
||||
(define (filter-and-fix predicate-fn update-fn list)
|
||||
(let loop ((list list))
|
||||
(cond ((null? list) '())
|
||||
((predicate-fn (car list))
|
||||
(cons (update-fn (car list)) (loop (cdr list))))
|
||||
(else (loop (cdr list))))))
|
||||
(define (fix-line line)
|
||||
(filter-and-fix
|
||||
(lambda (entry) (canonical? (car entry)))
|
||||
(lambda (entry) (cons (car entry)
|
||||
(find-canonical-representative (cdr entry) classes)))
|
||||
line))
|
||||
(if (null? table)
|
||||
'()
|
||||
(cons (car table)
|
||||
(filter-and-fix
|
||||
(lambda (entry) (canonical? (car entry)))
|
||||
(lambda (entry) (cons (car entry) (fix-line (cdr entry))))
|
||||
(cdr table)))))
|
||||
(make-internal-graph
|
||||
(map (lambda (class) (fix (car class))) classes)
|
||||
(fix-table (already-met graph))
|
||||
(fix-table (already-joined graph))))
|
||||
|
||||
;; USEFUL NODES
|
||||
|
||||
(define none-node (make-node 'none #t))
|
||||
(define (none-node? node) (eq? node none-node))
|
||||
|
||||
(define any-node (make-node 'any '()))
|
||||
(define (any-node? node) (eq? node any-node))
|
||||
|
||||
;; COLORED EDGE TESTS
|
||||
|
||||
(define (green-edge? from-node to-node)
|
||||
(cond ((any-node? from-node) #f)
|
||||
((none-node? from-node) #t)
|
||||
((memq to-node (green-edges from-node)) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (red-edge? from-node to-node)
|
||||
(cond ((any-node? from-node) #f)
|
||||
((none-node? from-node) #t)
|
||||
((memq to-node (red-edges from-node)) #t)
|
||||
(else #f)))
|
||||
|
||||
;; SIGNATURE
|
||||
|
||||
; Return signature (i.e. <arg, res>) given an operation and a node
|
||||
|
||||
(define sig
|
||||
(let ((none-comma-any (cons none-node any-node)))
|
||||
(lambda (op node) ; Returns (arg, res)
|
||||
(let ((the-edge (lookup-op op node)))
|
||||
(if (not (null? the-edge))
|
||||
(cons (arg-node the-edge) (res-node the-edge))
|
||||
none-comma-any)))))
|
||||
|
||||
; Selectors from signature
|
||||
|
||||
(define (arg pair) (car pair))
|
||||
(define (res pair) (cdr pair))
|
||||
|
||||
;; CONFORMITY
|
||||
|
||||
(define (conforms? t1 t2)
|
||||
(define nodes-with-red-edges-out '())
|
||||
(define (add-red-edge! from-node to-node)
|
||||
(set-red-edges! from-node (adjoin to-node (red-edges from-node)))
|
||||
(set! nodes-with-red-edges-out
|
||||
(adjoin from-node nodes-with-red-edges-out)))
|
||||
(define (greenify-red-edges! from-node)
|
||||
(set-green-edges! from-node
|
||||
(append (red-edges from-node) (green-edges from-node)))
|
||||
(set-red-edges! from-node '()))
|
||||
(define (delete-red-edges! from-node)
|
||||
(set-red-edges! from-node '()))
|
||||
(define (does-conform t1 t2)
|
||||
(cond ((or (none-node? t1) (any-node? t2)) #t)
|
||||
((or (any-node? t1) (none-node? t2)) #f)
|
||||
((green-edge? t1 t2) #t)
|
||||
((red-edge? t1 t2) #t)
|
||||
(else
|
||||
(add-red-edge! t1 t2)
|
||||
(let loop ((blues (blue-edges t2)))
|
||||
(if (null? blues)
|
||||
#t
|
||||
(let* ((current-edge (car blues))
|
||||
(phi (operation current-edge)))
|
||||
(and (has-op? phi t1)
|
||||
(does-conform
|
||||
(res (sig phi t1))
|
||||
(res (sig phi t2)))
|
||||
(does-conform
|
||||
(arg (sig phi t2))
|
||||
(arg (sig phi t1)))
|
||||
(loop (cdr blues)))))))))
|
||||
(let ((result (does-conform t1 t2)))
|
||||
(for-each (if result greenify-red-edges! delete-red-edges!)
|
||||
nodes-with-red-edges-out)
|
||||
result))
|
||||
|
||||
(define (equivalent? a b)
|
||||
(and (conforms? a b) (conforms? b a)))
|
||||
|
||||
;; EQUIVALENCE CLASSIFICATION
|
||||
; Given a list of nodes, return a list of equivalence classes
|
||||
|
||||
(define (classify nodes)
|
||||
(let node-loop ((classes '())
|
||||
(nodes nodes))
|
||||
(if (null? nodes)
|
||||
(map (lambda (class)
|
||||
(sort-list class
|
||||
(lambda (node1 node2)
|
||||
(< (string-length (name node1))
|
||||
(string-length (name node2))))))
|
||||
classes)
|
||||
(let ((this-node (car nodes)))
|
||||
(define (add-node classes)
|
||||
(cond ((null? classes) (list (list this-node)))
|
||||
((equivalent? this-node (caar classes))
|
||||
(cons (cons this-node (car classes))
|
||||
(cdr classes)))
|
||||
(else (cons (car classes)
|
||||
(add-node (cdr classes))))))
|
||||
(node-loop (add-node classes)
|
||||
(cdr nodes))))))
|
||||
|
||||
; Given a node N and a classified set of nodes,
|
||||
; find the canonical member corresponding to N
|
||||
|
||||
(define (find-canonical-representative element classification)
|
||||
(let loop ((classes classification))
|
||||
(cond ((null? classes) (error #f "Can't classify" element))
|
||||
((memq element (car classes)) (car (car classes)))
|
||||
(else (loop (cdr classes))))))
|
||||
|
||||
; Reduce a graph by taking only one member of each equivalence
|
||||
; class and canonicalizing all outbound pointers
|
||||
|
||||
(define (reduce graph)
|
||||
(let ((classes (classify (graph-nodes graph))))
|
||||
(canonicalize-graph graph classes)))
|
||||
|
||||
;; TWO DIMENSIONAL TABLES
|
||||
|
||||
(define (make-empty-table) (list 'TABLE))
|
||||
(define (lookup table x y)
|
||||
(let ((one (assq x (cdr table))))
|
||||
(if one
|
||||
(let ((two (assq y (cdr one))))
|
||||
(if two (cdr two) #f))
|
||||
#f)))
|
||||
(define (insert! table x y value)
|
||||
(define (make-singleton-table x y)
|
||||
(list (cons x y)))
|
||||
(let ((one (assq x (cdr table))))
|
||||
(if one
|
||||
(set-cdr! one (cons (cons y value) (cdr one)))
|
||||
(set-cdr! table (cons (cons x (make-singleton-table y value))
|
||||
(cdr table))))))
|
||||
|
||||
;; MEET/JOIN
|
||||
; These update the graph when computing the node for node1*node2
|
||||
|
||||
(define (blue-edge-operate arg-fn res-fn graph op sig1 sig2)
|
||||
(make-blue-edge op
|
||||
(arg-fn graph (arg sig1) (arg sig2))
|
||||
(res-fn graph (res sig1) (res sig2))))
|
||||
|
||||
(define (meet graph node1 node2)
|
||||
(cond ((eq? node1 node2) node1)
|
||||
((or (any-node? node1) (any-node? node2)) any-node) ; canonicalize
|
||||
((none-node? node1) node2)
|
||||
((none-node? node2) node1)
|
||||
((lookup (already-met graph) node1 node2)) ; return it if found
|
||||
((conforms? node1 node2) node2)
|
||||
((conforms? node2 node1) node1)
|
||||
(else
|
||||
(let ((result
|
||||
(make-node (string-append "(" (name node1) " ^ " (name node2) ")"))))
|
||||
(add-graph-nodes! graph result)
|
||||
(insert! (already-met graph) node1 node2 result)
|
||||
(set-blue-edges! result
|
||||
(map
|
||||
(lambda (op)
|
||||
(blue-edge-operate join meet graph op (sig op node1) (sig op node2)))
|
||||
(intersect (map operation (blue-edges node1))
|
||||
(map operation (blue-edges node2)))))
|
||||
result))))
|
||||
|
||||
(define (join graph node1 node2)
|
||||
(cond ((eq? node1 node2) node1)
|
||||
((any-node? node1) node2)
|
||||
((any-node? node2) node1)
|
||||
((or (none-node? node1) (none-node? node2)) none-node) ; canonicalize
|
||||
((lookup (already-joined graph) node1 node2)) ; return it if found
|
||||
((conforms? node1 node2) node1)
|
||||
((conforms? node2 node1) node2)
|
||||
(else
|
||||
(let ((result
|
||||
(make-node (string-append "(" (name node1) " v " (name node2) ")"))))
|
||||
(add-graph-nodes! graph result)
|
||||
(insert! (already-joined graph) node1 node2 result)
|
||||
(set-blue-edges! result
|
||||
(map
|
||||
(lambda (op)
|
||||
(blue-edge-operate meet join graph op (sig op node1) (sig op node2)))
|
||||
(union (map operation (blue-edges node1))
|
||||
(map operation (blue-edges node2)))))
|
||||
result))))
|
||||
|
||||
;; MAKE A LATTICE FROM A GRAPH
|
||||
|
||||
(define (make-lattice g print?)
|
||||
(define (step g)
|
||||
(let* ((copy (copy-graph g))
|
||||
(nodes (graph-nodes copy)))
|
||||
(for-each (lambda (first)
|
||||
(for-each (lambda (second)
|
||||
(meet copy first second) (join copy first second))
|
||||
nodes))
|
||||
nodes)
|
||||
copy))
|
||||
(define (loop g count)
|
||||
(if print? (display count))
|
||||
(let ((lattice (step g)))
|
||||
(if print? (begin (display " -> ") (display (length (graph-nodes lattice)))))
|
||||
(let* ((new-g (reduce lattice))
|
||||
(new-count (length (graph-nodes new-g))))
|
||||
(if (= new-count count)
|
||||
(begin
|
||||
(if print? (newline))
|
||||
new-g)
|
||||
(begin
|
||||
(if print? (begin (display " -> ") (display new-count) (newline)))
|
||||
(loop new-g new-count))))))
|
||||
(let ((graph
|
||||
(apply make-graph
|
||||
(adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))
|
||||
(loop graph (length (graph-nodes graph)))))
|
||||
|
||||
;; DEBUG and TEST
|
||||
|
||||
(define a '())
|
||||
(define b '())
|
||||
(define c '())
|
||||
(define d '())
|
||||
|
||||
(define (setup a0 b0 c0 d0)
|
||||
(set! a (make-node a0))
|
||||
(set! b (make-node b0))
|
||||
(set-blue-edges! a (list (make-blue-edge 'phi any-node b)))
|
||||
(set-blue-edges! b (list (make-blue-edge 'phi any-node a)
|
||||
(make-blue-edge 'theta any-node b)))
|
||||
(set! c (make-node c0))
|
||||
(set! d (make-node d0))
|
||||
(set-blue-edges! c (list (make-blue-edge 'theta any-node b)))
|
||||
(set-blue-edges! d (list (make-blue-edge 'phi any-node c)
|
||||
(make-blue-edge 'theta any-node d)))
|
||||
'(made a b c d))
|
||||
|
||||
(define (test a0 b0 c0 d0)
|
||||
(setup a0 b0 c0 d0)
|
||||
(map name
|
||||
(graph-nodes (make-lattice (make-graph a b c d any-node none-node) #f))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s (number->string count))
|
||||
(name "conform"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s)
|
||||
count
|
||||
(lambda () (apply test input1))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
;;; 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))
|
||||
|
||||
(define (cpstak x y z)
|
||||
|
||||
(define (tak x y z k)
|
||||
(if (not (< y x))
|
||||
(k z)
|
||||
(tak (- x 1)
|
||||
y
|
||||
z
|
||||
(lambda (v1)
|
||||
(tak (- y 1)
|
||||
z
|
||||
x
|
||||
(lambda (v2)
|
||||
(tak (- z 1)
|
||||
x
|
||||
y
|
||||
(lambda (v3)
|
||||
(tak v1 v2 v3 k)))))))))
|
||||
|
||||
(tak x y z (lambda (a) a)))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(input2 (read))
|
||||
(input3 (read))
|
||||
(output (read))
|
||||
(s4 (number->string count))
|
||||
(s3 (number->string input3))
|
||||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "cpstak"))
|
||||
(run-r6rs-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)))))
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
;;; CTAK -- A version of the TAK procedure that uses continuations.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
|
||||
(define (ctak x y z)
|
||||
(call-with-current-continuation
|
||||
(lambda (k) (ctak-aux k x y z))))
|
||||
|
||||
(define (ctak-aux k x y z)
|
||||
(if (not (< y x))
|
||||
(k z)
|
||||
(call-with-current-continuation
|
||||
(lambda (k)
|
||||
(ctak-aux
|
||||
k
|
||||
(call-with-current-continuation
|
||||
(lambda (k) (ctak-aux k (- x 1) y z)))
|
||||
(call-with-current-continuation
|
||||
(lambda (k) (ctak-aux k (- y 1) z x)))
|
||||
(call-with-current-continuation
|
||||
(lambda (k) (ctak-aux k (- z 1) x y))))))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(input2 (read))
|
||||
(input3 (read))
|
||||
(output (read))
|
||||
(s4 (number->string count))
|
||||
(s3 (number->string input3))
|
||||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "ctak"))
|
||||
(run-r6rs-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)))))
|
||||
|
|
@ -0,0 +1,91 @@
|
|||
;;; DDERIV -- Table-driven symbolic derivation.
|
||||
|
||||
;;; Returns the wrong answer for quotients.
|
||||
;;; Fortunately these aren't used in the benchmark.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple)
|
||||
(rnrs hashtables)
|
||||
(rnrs mutable-pairs))
|
||||
|
||||
(define (lookup key table)
|
||||
(let loop ((x table))
|
||||
(if (null? x)
|
||||
#f
|
||||
(let ((pair (car x)))
|
||||
(if (eq? (car pair) key)
|
||||
pair
|
||||
(loop (cdr x)))))))
|
||||
|
||||
(define properties (make-hashtable symbol-hash eq?))
|
||||
|
||||
(define (get key1 key2)
|
||||
(let ((x (hashtable-ref properties key1 #f)))
|
||||
(if x
|
||||
(let ((y (lookup key2 x)))
|
||||
(if y
|
||||
(cdr y)
|
||||
#f))
|
||||
#f)))
|
||||
|
||||
(define (put key1 key2 val)
|
||||
(let ((x (hashtable-ref properties key1 #f)))
|
||||
(if x
|
||||
(let ((y (lookup key2 x)))
|
||||
(if y
|
||||
(set-cdr! y val)
|
||||
(set-cdr! x (cons (cons key2 val) (cdr x)))))
|
||||
(hashtable-set! properties key1 (list (cons key2 val))))))
|
||||
|
||||
(define (my+dderiv a)
|
||||
(cons '+
|
||||
(map dderiv (cdr a))))
|
||||
|
||||
(define (my-dderiv a)
|
||||
(cons '-
|
||||
(map dderiv (cdr a))))
|
||||
|
||||
(define (*dderiv a)
|
||||
(list '*
|
||||
a
|
||||
(cons '+
|
||||
(map (lambda (a) (list '/ (dderiv a) a)) (cdr a)))))
|
||||
|
||||
(define (/dderiv a)
|
||||
(list '-
|
||||
(list '/
|
||||
(dderiv (cadr a))
|
||||
(caddr a))
|
||||
(list '/
|
||||
(cadr a)
|
||||
(list '*
|
||||
(caddr a)
|
||||
(caddr a)
|
||||
(dderiv (caddr a))))))
|
||||
|
||||
(put '+ 'dderiv my+dderiv)
|
||||
(put '- 'dderiv my-dderiv)
|
||||
(put '* 'dderiv *dderiv)
|
||||
(put '/ 'dderiv /dderiv)
|
||||
|
||||
(define (dderiv a)
|
||||
(if (not (pair? a))
|
||||
(if (eq? a 'x) 1 0)
|
||||
(let ((f (get (car a) 'dderiv)))
|
||||
(if f
|
||||
(f a)
|
||||
(error #f "No derivation method available")))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s (number->string count))
|
||||
(name "dderiv"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s)
|
||||
count
|
||||
(lambda () (dderiv (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
;;; DERIV -- Symbolic derivation.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs io simple))
|
||||
|
||||
;;; Returns the wrong answer for quotients.
|
||||
;;; Fortunately these aren't used in the benchmark.
|
||||
|
||||
(define (deriv a)
|
||||
(cond ((not (pair? a))
|
||||
(if (eq? a 'x) 1 0))
|
||||
((eq? (car a) '+)
|
||||
(cons '+
|
||||
(map deriv (cdr a))))
|
||||
((eq? (car a) '-)
|
||||
(cons '-
|
||||
(map deriv (cdr a))))
|
||||
((eq? (car a) '*)
|
||||
(list '*
|
||||
a
|
||||
(cons '+
|
||||
(map (lambda (a) (list '/ (deriv a) a)) (cdr a)))))
|
||||
((eq? (car a) '/)
|
||||
(list '-
|
||||
(list '/
|
||||
(deriv (cadr a))
|
||||
(caddr a))
|
||||
(list '/
|
||||
(cadr a)
|
||||
(list '*
|
||||
(caddr a)
|
||||
(caddr a)
|
||||
(deriv (caddr a))))))
|
||||
(else
|
||||
(error #f "No derivation method available"))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s (number->string count))
|
||||
(name "deriv"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s)
|
||||
count
|
||||
(lambda () (deriv (hide count input1)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
;;; DESTRUC -- Destructive operation benchmark.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple)
|
||||
(rnrs mutable-pairs))
|
||||
|
||||
(define (append-to-tail! x y)
|
||||
(if (null? x)
|
||||
y
|
||||
(let loop ((a x) (b (cdr x)))
|
||||
(if (null? b)
|
||||
(begin
|
||||
(set-cdr! a y)
|
||||
x)
|
||||
(loop b (cdr b))))))
|
||||
|
||||
(define (destructive n m)
|
||||
(let ((l (do ((i 10 (- i 1)) (a '() (cons '() a)))
|
||||
((= i 0) a))))
|
||||
(do ((i n (- i 1)))
|
||||
((= i 0) l)
|
||||
(cond ((null? (car l))
|
||||
(do ((l l (cdr l)))
|
||||
((null? l))
|
||||
(if (null? (car l)) (set-car! l (cons '() '())))
|
||||
(append-to-tail! (car l)
|
||||
(do ((j m (- j 1)) (a '() (cons '() a)))
|
||||
((= j 0) a)))))
|
||||
(else
|
||||
(do ((l1 l (cdr l1)) (l2 (cdr l) (cdr l2)))
|
||||
((null? l2))
|
||||
(set-cdr! (do ((j (div (length (car l2)) 2) (- j 1))
|
||||
(a (car l2) (cdr a)))
|
||||
((zero? j) a)
|
||||
(set-car! a i))
|
||||
(let ((n (div (length (car l1)) 2)))
|
||||
(cond ((= n 0)
|
||||
(set-car! l1 '())
|
||||
(car l1))
|
||||
(else
|
||||
(do ((j n (- j 1)) (a (car l1) (cdr a)))
|
||||
((= j 1)
|
||||
(let ((x (cdr a)))
|
||||
(set-cdr! a '())
|
||||
x))
|
||||
(set-car! a i))))))))))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(input2 (read))
|
||||
(output (read))
|
||||
(s3 (number->string count))
|
||||
(s2 (number->string input2))
|
||||
(s1 (number->string input1))
|
||||
(name "destruc"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s1 ":" s2 ":" s3)
|
||||
count
|
||||
(lambda ()
|
||||
(destructive (hide count input1) (hide count input2)))
|
||||
(lambda (result) (equal? result output)))))
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
;;; DIVITER -- Benchmark which divides by 2 using lists of n ()'s.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
|
||||
(define (create-n n)
|
||||
(do ((n n (- n 1))
|
||||
(a '() (cons '() a)))
|
||||
((= n 0) a)))
|
||||
|
||||
(define (iterative-div2 l)
|
||||
(do ((l l (cddr l))
|
||||
(a '() (cons (car l) a)))
|
||||
((null? l) a)))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(ll (create-n (hide count input1)))
|
||||
(name "diviter"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda ()
|
||||
(iterative-div2 ll))
|
||||
(lambda (result) (equal? (length result) output)))))
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
;;; DIVREC -- Benchmark which divides by 2 using lists of n ()'s.
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs control)
|
||||
(rnrs io simple))
|
||||
|
||||
(define (create-n n)
|
||||
(do ((n n (- n 1))
|
||||
(a '() (cons '() a)))
|
||||
((= n 0) a)))
|
||||
|
||||
(define (recursive-div2 l)
|
||||
(cond ((null? l) '())
|
||||
(else (cons (car l) (recursive-div2 (cddr l))))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(ll (create-n (hide count input1)))
|
||||
(name "divrec"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda ()
|
||||
(recursive-div2 ll))
|
||||
(lambda (result) (equal? (length result) output)))))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,662 @@
|
|||
;;; EARLEY -- Earley's parser, written by Marc Feeley.
|
||||
|
||||
; (make-parser grammar lexer) is used to create a parser from the grammar
|
||||
; description `grammar' and the lexer function `lexer'.
|
||||
;
|
||||
; A grammar is a list of definitions. Each definition defines a non-terminal
|
||||
; by a set of rules. Thus a definition has the form: (nt rule1 rule2...).
|
||||
; A given non-terminal can only be defined once. The first non-terminal
|
||||
; defined is the grammar's goal. Each rule is a possibly empty list of
|
||||
; non-terminals. Thus a rule has the form: (nt1 nt2...). A non-terminal
|
||||
; can be any scheme value. Note that all grammar symbols are treated as
|
||||
; non-terminals. This is fine though because the lexer will be outputing
|
||||
; non-terminals.
|
||||
;
|
||||
; The lexer defines what a token is and the mapping between tokens and
|
||||
; the grammar's non-terminals. It is a function of one argument, the input,
|
||||
; that returns the list of tokens corresponding to the input. Each token is
|
||||
; represented by a list. The first element is some `user-defined' information
|
||||
; associated with the token and the rest represents the token's class(es) (as a
|
||||
; list of non-terminals that this token corresponds to).
|
||||
;
|
||||
; The result of `make-parser' is a function that parses the single input it
|
||||
; is given into the grammar's goal. The result is a `parse' which can be
|
||||
; manipulated with the procedures: `parse->parsed?', `parse->trees'
|
||||
; and `parse->nb-trees' (see below).
|
||||
;
|
||||
; Let's assume that we want a parser for the grammar
|
||||
;
|
||||
; S -> x = E
|
||||
; E -> E + E | V
|
||||
; V -> V y |
|
||||
;
|
||||
; and that the input to the parser is a string of characters. Also, assume we
|
||||
; would like to map the characters `x', `y', `+' and `=' into the corresponding
|
||||
; non-terminals in the grammar. Such a parser could be created with
|
||||
;
|
||||
; (make-parser
|
||||
; '(
|
||||
; (s (x = e))
|
||||
; (e (e + e) (v))
|
||||
; (v (v y) ())
|
||||
; )
|
||||
; (lambda (str)
|
||||
; (map (lambda (char)
|
||||
; (list char ; user-info = the character itself
|
||||
; (case char
|
||||
; ((#\x) 'x)
|
||||
; ((#\y) 'y)
|
||||
; ((#\+) '+)
|
||||
; ((#\=) '=)
|
||||
; (else (fatal-error "lexer error")))))
|
||||
; (string->list str)))
|
||||
; )
|
||||
;
|
||||
; An alternative definition (that does not check for lexical errors) is
|
||||
;
|
||||
; (make-parser
|
||||
; '(
|
||||
; (s (#\x #\= e))
|
||||
; (e (e #\+ e) (v))
|
||||
; (v (v #\y) ())
|
||||
; )
|
||||
; (lambda (str) (map (lambda (char) (list char char)) (string->list str)))
|
||||
; )
|
||||
;
|
||||
; To help with the rest of the discussion, here are a few definitions:
|
||||
;
|
||||
; An input pointer (for an input of `n' tokens) is a value between 0 and `n'.
|
||||
; It indicates a point between two input tokens (0 = beginning, `n' = end).
|
||||
; For example, if `n' = 4, there are 5 input pointers:
|
||||
;
|
||||
; input token1 token2 token3 token4
|
||||
; input pointers 0 1 2 3 4
|
||||
;
|
||||
; A configuration indicates the extent to which a given rule is parsed (this
|
||||
; is the common `dot notation'). For simplicity, a configuration is
|
||||
; represented as an integer, with successive configurations in the same
|
||||
; rule associated with successive integers. It is assumed that the grammar
|
||||
; has been extended with rules to aid scanning. These rules are of the
|
||||
; form `nt ->', and there is one such rule for every non-terminal. Note
|
||||
; that these rules are special because they only apply when the corresponding
|
||||
; non-terminal is returned by the lexer.
|
||||
;
|
||||
; A configuration set is a configuration grouped with the set of input pointers
|
||||
; representing where the head non-terminal of the configuration was predicted.
|
||||
;
|
||||
; Here are the rules and configurations for the grammar given above:
|
||||
;
|
||||
; S -> . \
|
||||
; 0 |
|
||||
; x -> . |
|
||||
; 1 |
|
||||
; = -> . |
|
||||
; 2 |
|
||||
; E -> . |
|
||||
; 3 > special rules (for scanning)
|
||||
; + -> . |
|
||||
; 4 |
|
||||
; V -> . |
|
||||
; 5 |
|
||||
; y -> . |
|
||||
; 6 /
|
||||
; S -> . x . = . E .
|
||||
; 7 8 9 10
|
||||
; E -> . E . + . E .
|
||||
; 11 12 13 14
|
||||
; E -> . V .
|
||||
; 15 16
|
||||
; V -> . V . y .
|
||||
; 17 18 19
|
||||
; V -> .
|
||||
; 20
|
||||
;
|
||||
; Starters of the non-terminal `nt' are configurations that are leftmost
|
||||
; in a non-special rule for `nt'. Enders of the non-terminal `nt' are
|
||||
; configurations that are rightmost in any rule for `nt'. Predictors of the
|
||||
; non-terminal `nt' are configurations that are directly to the left of `nt'
|
||||
; in any rule.
|
||||
;
|
||||
; For the grammar given above,
|
||||
;
|
||||
; Starters of V = (17 20)
|
||||
; Enders of V = (5 19 20)
|
||||
; Predictors of V = (15 17)
|
||||
|
||||
(import (rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs io simple))
|
||||
|
||||
(define (make-parser grammar lexer)
|
||||
|
||||
(define (non-terminals grammar) ; return vector of non-terminals in grammar
|
||||
|
||||
(define (add-nt nt nts)
|
||||
(if (member nt nts) nts (cons nt nts))) ; use equal? for equality tests
|
||||
|
||||
(let def-loop ((defs grammar) (nts '()))
|
||||
(if (pair? defs)
|
||||
(let* ((def (car defs))
|
||||
(head (car def)))
|
||||
(let rule-loop ((rules (cdr def))
|
||||
(nts (add-nt head nts)))
|
||||
(if (pair? rules)
|
||||
(let ((rule (car rules)))
|
||||
(let loop ((l rule) (nts nts))
|
||||
(if (pair? l)
|
||||
(let ((nt (car l)))
|
||||
(loop (cdr l) (add-nt nt nts)))
|
||||
(rule-loop (cdr rules) nts))))
|
||||
(def-loop (cdr defs) nts))))
|
||||
(list->vector (reverse nts))))) ; goal non-terminal must be at index 0
|
||||
|
||||
(define (ind nt nts) ; return index of non-terminal `nt' in `nts'
|
||||
(let loop ((i (- (vector-length nts) 1)))
|
||||
(if (>= i 0)
|
||||
(if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
|
||||
#f)))
|
||||
|
||||
(define (nb-configurations grammar) ; return nb of configurations in grammar
|
||||
(let def-loop ((defs grammar) (nb-confs 0))
|
||||
(if (pair? defs)
|
||||
(let ((def (car defs)))
|
||||
(let rule-loop ((rules (cdr def)) (nb-confs nb-confs))
|
||||
(if (pair? rules)
|
||||
(let ((rule (car rules)))
|
||||
(let loop ((l rule) (nb-confs nb-confs))
|
||||
(if (pair? l)
|
||||
(loop (cdr l) (+ nb-confs 1))
|
||||
(rule-loop (cdr rules) (+ nb-confs 1)))))
|
||||
(def-loop (cdr defs) nb-confs))))
|
||||
nb-confs)))
|
||||
|
||||
; First, associate a numeric identifier to every non-terminal in the
|
||||
; grammar (with the goal non-terminal associated with 0).
|
||||
;
|
||||
; So, for the grammar given above we get:
|
||||
;
|
||||
; s -> 0 x -> 1 = -> 4 e ->3 + -> 4 v -> 5 y -> 6
|
||||
|
||||
(let* ((nts (non-terminals grammar)) ; id map = list of non-terms
|
||||
(nb-nts (vector-length nts)) ; the number of non-terms
|
||||
(nb-confs (+ (nb-configurations grammar) nb-nts)) ; the nb of confs
|
||||
(starters (make-vector nb-nts '())) ; starters for every non-term
|
||||
(enders (make-vector nb-nts '())) ; enders for every non-term
|
||||
(predictors (make-vector nb-nts '())) ; predictors for every non-term
|
||||
(steps (make-vector nb-confs #f)) ; what to do in a given conf
|
||||
(names (make-vector nb-confs #f))) ; name of rules
|
||||
|
||||
(define (setup-tables grammar nts starters enders predictors steps names)
|
||||
|
||||
(define (add-conf conf nt nts class)
|
||||
(let ((i (ind nt nts)))
|
||||
(vector-set! class i (cons conf (vector-ref class i)))))
|
||||
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
|
||||
(let nt-loop ((i (- nb-nts 1)))
|
||||
(if (>= i 0)
|
||||
(begin
|
||||
(vector-set! steps i (- i nb-nts))
|
||||
(vector-set! names i (list (vector-ref nts i) 0))
|
||||
(vector-set! enders i (list i))
|
||||
(nt-loop (- i 1)))))
|
||||
|
||||
(let def-loop ((defs grammar) (conf (vector-length nts)))
|
||||
(if (pair? defs)
|
||||
(let* ((def (car defs))
|
||||
(head (car def)))
|
||||
(let rule-loop ((rules (cdr def)) (conf conf) (rule-num 1))
|
||||
(if (pair? rules)
|
||||
(let ((rule (car rules)))
|
||||
(vector-set! names conf (list head rule-num))
|
||||
(add-conf conf head nts starters)
|
||||
(let loop ((l rule) (conf conf))
|
||||
(if (pair? l)
|
||||
(let ((nt (car l)))
|
||||
(vector-set! steps conf (ind nt nts))
|
||||
(add-conf conf nt nts predictors)
|
||||
(loop (cdr l) (+ conf 1)))
|
||||
(begin
|
||||
(vector-set! steps conf (- (ind head nts) nb-nts))
|
||||
(add-conf conf head nts enders)
|
||||
(rule-loop (cdr rules) (+ conf 1) (+ rule-num 1))))))
|
||||
(def-loop (cdr defs) conf))))))))
|
||||
|
||||
; Now, for each non-terminal, compute the starters, enders and predictors and
|
||||
; the names and steps tables.
|
||||
|
||||
(setup-tables grammar nts starters enders predictors steps names)
|
||||
|
||||
; Build the parser description
|
||||
|
||||
(let ((parser-descr (vector lexer
|
||||
nts
|
||||
starters
|
||||
enders
|
||||
predictors
|
||||
steps
|
||||
names)))
|
||||
(lambda (input)
|
||||
|
||||
(define (ind nt nts) ; return index of non-terminal `nt' in `nts'
|
||||
(let loop ((i (- (vector-length nts) 1)))
|
||||
(if (>= i 0)
|
||||
(if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
|
||||
#f)))
|
||||
|
||||
(define (comp-tok tok nts) ; transform token to parsing format
|
||||
(let loop ((l1 (cdr tok)) (l2 '()))
|
||||
(if (pair? l1)
|
||||
(let ((i (ind (car l1) nts)))
|
||||
(if i
|
||||
(loop (cdr l1) (cons i l2))
|
||||
(loop (cdr l1) l2)))
|
||||
(cons (car tok) (reverse l2)))))
|
||||
|
||||
(define (input->tokens input lexer nts)
|
||||
(list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))
|
||||
|
||||
(define (make-states nb-toks nb-confs)
|
||||
(let ((states (make-vector (+ nb-toks 1) #f)))
|
||||
(let loop ((i nb-toks))
|
||||
(if (>= i 0)
|
||||
(let ((v (make-vector (+ nb-confs 1) #f)))
|
||||
(vector-set! v 0 -1)
|
||||
(vector-set! states i v)
|
||||
(loop (- i 1)))
|
||||
states))))
|
||||
|
||||
(define (conf-set-get state conf)
|
||||
(vector-ref state (+ conf 1)))
|
||||
|
||||
(define (conf-set-get* state state-num conf)
|
||||
(let ((conf-set (conf-set-get state conf)))
|
||||
(if conf-set
|
||||
conf-set
|
||||
(let ((conf-set (make-vector (+ state-num 6) #f)))
|
||||
(vector-set! conf-set 1 -3) ; old elems tail (points to head)
|
||||
(vector-set! conf-set 2 -1) ; old elems head
|
||||
(vector-set! conf-set 3 -1) ; new elems tail (points to head)
|
||||
(vector-set! conf-set 4 -1) ; new elems head
|
||||
(vector-set! state (+ conf 1) conf-set)
|
||||
conf-set))))
|
||||
|
||||
(define (conf-set-merge-new! conf-set)
|
||||
(vector-set! conf-set
|
||||
(+ (vector-ref conf-set 1) 5)
|
||||
(vector-ref conf-set 4))
|
||||
(vector-set! conf-set 1 (vector-ref conf-set 3))
|
||||
(vector-set! conf-set 3 -1)
|
||||
(vector-set! conf-set 4 -1))
|
||||
|
||||
(define (conf-set-head conf-set)
|
||||
(vector-ref conf-set 2))
|
||||
|
||||
(define (conf-set-next conf-set i)
|
||||
(vector-ref conf-set (+ i 5)))
|
||||
|
||||
(define (conf-set-member? state conf i)
|
||||
(let ((conf-set (vector-ref state (+ conf 1))))
|
||||
(if conf-set
|
||||
(conf-set-next conf-set i)
|
||||
#f)))
|
||||
|
||||
(define (conf-set-adjoin state conf-set conf i)
|
||||
(let ((tail (vector-ref conf-set 3))) ; put new element at tail
|
||||
(vector-set! conf-set (+ i 5) -1)
|
||||
(vector-set! conf-set (+ tail 5) i)
|
||||
(vector-set! conf-set 3 i)
|
||||
(if (< tail 0)
|
||||
(begin
|
||||
(vector-set! conf-set 0 (vector-ref state 0))
|
||||
(vector-set! state 0 conf)))))
|
||||
|
||||
(define (conf-set-adjoin* states state-num l i)
|
||||
(let ((state (vector-ref states state-num)))
|
||||
(let loop ((l1 l))
|
||||
(if (pair? l1)
|
||||
(let* ((conf (car l1))
|
||||
(conf-set (conf-set-get* state state-num conf)))
|
||||
(if (not (conf-set-next conf-set i))
|
||||
(begin
|
||||
(conf-set-adjoin state conf-set conf i)
|
||||
(loop (cdr l1)))
|
||||
(loop (cdr l1))))))))
|
||||
|
||||
(define (conf-set-adjoin** states states* state-num conf i)
|
||||
(let ((state (vector-ref states state-num)))
|
||||
(if (conf-set-member? state conf i)
|
||||
(let* ((state* (vector-ref states* state-num))
|
||||
(conf-set* (conf-set-get* state* state-num conf)))
|
||||
(if (not (conf-set-next conf-set* i))
|
||||
(conf-set-adjoin state* conf-set* conf i))
|
||||
#t)
|
||||
#f)))
|
||||
|
||||
(define (conf-set-union state conf-set conf other-set)
|
||||
(let loop ((i (conf-set-head other-set)))
|
||||
(if (>= i 0)
|
||||
(if (not (conf-set-next conf-set i))
|
||||
(begin
|
||||
(conf-set-adjoin state conf-set conf i)
|
||||
(loop (conf-set-next other-set i)))
|
||||
(loop (conf-set-next other-set i))))))
|
||||
|
||||
(define (forw states state-num starters enders predictors steps nts)
|
||||
|
||||
(define (predict state state-num conf-set conf nt starters enders)
|
||||
|
||||
; add configurations which start the non-terminal `nt' to the
|
||||
; right of the dot
|
||||
|
||||
(let loop1 ((l (vector-ref starters nt)))
|
||||
(if (pair? l)
|
||||
(let* ((starter (car l))
|
||||
(starter-set (conf-set-get* state state-num starter)))
|
||||
(if (not (conf-set-next starter-set state-num))
|
||||
(begin
|
||||
(conf-set-adjoin state starter-set starter state-num)
|
||||
(loop1 (cdr l)))
|
||||
(loop1 (cdr l))))))
|
||||
|
||||
; check for possible completion of the non-terminal `nt' to the
|
||||
; right of the dot
|
||||
|
||||
(let loop2 ((l (vector-ref enders nt)))
|
||||
(if (pair? l)
|
||||
(let ((ender (car l)))
|
||||
(if (conf-set-member? state ender state-num)
|
||||
(let* ((next (+ conf 1))
|
||||
(next-set (conf-set-get* state state-num next)))
|
||||
(conf-set-union state next-set next conf-set)
|
||||
(loop2 (cdr l)))
|
||||
(loop2 (cdr l)))))))
|
||||
|
||||
(define (reduce states state state-num conf-set head preds)
|
||||
|
||||
; a non-terminal is now completed so check for reductions that
|
||||
; are now possible at the configurations `preds'
|
||||
|
||||
(let loop1 ((l preds))
|
||||
(if (pair? l)
|
||||
(let ((pred (car l)))
|
||||
(let loop2 ((i head))
|
||||
(if (>= i 0)
|
||||
(let ((pred-set (conf-set-get (vector-ref states i) pred)))
|
||||
(if pred-set
|
||||
(let* ((next (+ pred 1))
|
||||
(next-set (conf-set-get* state state-num next)))
|
||||
(conf-set-union state next-set next pred-set)))
|
||||
(loop2 (conf-set-next conf-set i)))
|
||||
(loop1 (cdr l))))))))
|
||||
|
||||
(let ((state (vector-ref states state-num))
|
||||
(nb-nts (vector-length nts)))
|
||||
(let loop ()
|
||||
(let ((conf (vector-ref state 0)))
|
||||
(if (>= conf 0)
|
||||
(let* ((step (vector-ref steps conf))
|
||||
(conf-set (vector-ref state (+ conf 1)))
|
||||
(head (vector-ref conf-set 4)))
|
||||
(vector-set! state 0 (vector-ref conf-set 0))
|
||||
(conf-set-merge-new! conf-set)
|
||||
(if (>= step 0)
|
||||
(predict state state-num conf-set conf step starters enders)
|
||||
(let ((preds (vector-ref predictors (+ step nb-nts))))
|
||||
(reduce states state state-num conf-set head preds)))
|
||||
(loop)))))))
|
||||
|
||||
(define (forward starters enders predictors steps nts toks)
|
||||
(let* ((nb-toks (vector-length toks))
|
||||
(nb-confs (vector-length steps))
|
||||
(states (make-states nb-toks nb-confs))
|
||||
(goal-starters (vector-ref starters 0)))
|
||||
(conf-set-adjoin* states 0 goal-starters 0) ; predict goal
|
||||
(forw states 0 starters enders predictors steps nts)
|
||||
(let loop ((i 0))
|
||||
(if (< i nb-toks)
|
||||
(let ((tok-nts (cdr (vector-ref toks i))))
|
||||
(conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token
|
||||
(forw states (+ i 1) starters enders predictors steps nts)
|
||||
(loop (+ i 1)))))
|
||||
states))
|
||||
|
||||
(define (produce conf i j enders steps toks states states* nb-nts)
|
||||
(let ((prev (- conf 1)))
|
||||
(if (and (>= conf nb-nts) (>= (vector-ref steps prev) 0))
|
||||
(let loop1 ((l (vector-ref enders (vector-ref steps prev))))
|
||||
(if (pair? l)
|
||||
(let* ((ender (car l))
|
||||
(ender-set (conf-set-get (vector-ref states j)
|
||||
ender)))
|
||||
(if ender-set
|
||||
(let loop2 ((k (conf-set-head ender-set)))
|
||||
(if (>= k 0)
|
||||
(begin
|
||||
(and (>= k i)
|
||||
(conf-set-adjoin** states states* k prev i)
|
||||
(conf-set-adjoin** states states* j ender k))
|
||||
(loop2 (conf-set-next ender-set k)))
|
||||
(loop1 (cdr l))))
|
||||
(loop1 (cdr l)))))))))
|
||||
|
||||
(define (back states states* state-num enders steps nb-nts toks)
|
||||
(let ((state* (vector-ref states* state-num)))
|
||||
(let loop1 ()
|
||||
(let ((conf (vector-ref state* 0)))
|
||||
(if (>= conf 0)
|
||||
(let* ((conf-set (vector-ref state* (+ conf 1)))
|
||||
(head (vector-ref conf-set 4)))
|
||||
(vector-set! state* 0 (vector-ref conf-set 0))
|
||||
(conf-set-merge-new! conf-set)
|
||||
(let loop2 ((i head))
|
||||
(if (>= i 0)
|
||||
(begin
|
||||
(produce conf i state-num enders steps
|
||||
toks states states* nb-nts)
|
||||
(loop2 (conf-set-next conf-set i)))
|
||||
(loop1)))))))))
|
||||
|
||||
(define (backward states enders steps nts toks)
|
||||
(let* ((nb-toks (vector-length toks))
|
||||
(nb-confs (vector-length steps))
|
||||
(nb-nts (vector-length nts))
|
||||
(states* (make-states nb-toks nb-confs))
|
||||
(goal-enders (vector-ref enders 0)))
|
||||
(let loop1 ((l goal-enders))
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(conf-set-adjoin** states states* nb-toks conf 0)
|
||||
(loop1 (cdr l)))))
|
||||
(let loop2 ((i nb-toks))
|
||||
(if (>= i 0)
|
||||
(begin
|
||||
(back states states* i enders steps nb-nts toks)
|
||||
(loop2 (- i 1)))))
|
||||
states*))
|
||||
|
||||
(define (parsed? nt i j nts enders states)
|
||||
(let ((nt* (ind nt nts)))
|
||||
(if nt*
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
(let loop ((l (vector-ref enders nt*)))
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(if (conf-set-member? (vector-ref states j) conf i)
|
||||
#t
|
||||
(loop (cdr l))))
|
||||
#f)))
|
||||
#f)))
|
||||
|
||||
(define (deriv-trees conf i j enders steps names toks states nb-nts)
|
||||
(let ((name (vector-ref names conf)))
|
||||
|
||||
(if name ; `conf' is at the start of a rule (either special or not)
|
||||
(if (< conf nb-nts)
|
||||
(list (list name (car (vector-ref toks i))))
|
||||
(list (list name)))
|
||||
|
||||
(let ((prev (- conf 1)))
|
||||
(let loop1 ((l1 (vector-ref enders (vector-ref steps prev)))
|
||||
(l2 '()))
|
||||
(if (pair? l1)
|
||||
(let* ((ender (car l1))
|
||||
(ender-set (conf-set-get (vector-ref states j)
|
||||
ender)))
|
||||
(if ender-set
|
||||
(let loop2 ((k (conf-set-head ender-set)) (l2 l2))
|
||||
(if (>= k 0)
|
||||
(if (and (>= k i)
|
||||
(conf-set-member? (vector-ref states k)
|
||||
prev i))
|
||||
(let ((prev-trees
|
||||
(deriv-trees prev i k enders steps names
|
||||
toks states nb-nts))
|
||||
(ender-trees
|
||||
(deriv-trees ender k j enders steps names
|
||||
toks states nb-nts)))
|
||||
(let loop3 ((l3 ender-trees) (l2 l2))
|
||||
(if (pair? l3)
|
||||
(let ((ender-tree (list (car l3))))
|
||||
(let loop4 ((l4 prev-trees) (l2 l2))
|
||||
(if (pair? l4)
|
||||
(loop4 (cdr l4)
|
||||
(cons (append (car l4)
|
||||
ender-tree)
|
||||
l2))
|
||||
(loop3 (cdr l3) l2))))
|
||||
(loop2 (conf-set-next ender-set k) l2))))
|
||||
(loop2 (conf-set-next ender-set k) l2))
|
||||
(loop1 (cdr l1) l2)))
|
||||
(loop1 (cdr l1) l2)))
|
||||
l2))))))
|
||||
|
||||
(define (deriv-trees* nt i j nts enders steps names toks states)
|
||||
(let ((nt* (ind nt nts)))
|
||||
(if nt*
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
(let loop ((l (vector-ref enders nt*)) (trees '()))
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(if (conf-set-member? (vector-ref states j) conf i)
|
||||
(loop (cdr l)
|
||||
(append (deriv-trees conf i j enders steps names
|
||||
toks states nb-nts)
|
||||
trees))
|
||||
(loop (cdr l) trees)))
|
||||
trees)))
|
||||
#f)))
|
||||
|
||||
(define (nb-deriv-trees conf i j enders steps toks states nb-nts)
|
||||
(let ((prev (- conf 1)))
|
||||
(if (or (< conf nb-nts) (< (vector-ref steps prev) 0))
|
||||
1
|
||||
(let loop1 ((l (vector-ref enders (vector-ref steps prev)))
|
||||
(n 0))
|
||||
(if (pair? l)
|
||||
(let* ((ender (car l))
|
||||
(ender-set (conf-set-get (vector-ref states j)
|
||||
ender)))
|
||||
(if ender-set
|
||||
(let loop2 ((k (conf-set-head ender-set)) (n n))
|
||||
(if (>= k 0)
|
||||
(if (and (>= k i)
|
||||
(conf-set-member? (vector-ref states k)
|
||||
prev i))
|
||||
(let ((nb-prev-trees
|
||||
(nb-deriv-trees prev i k enders steps
|
||||
toks states nb-nts))
|
||||
(nb-ender-trees
|
||||
(nb-deriv-trees ender k j enders steps
|
||||
toks states nb-nts)))
|
||||
(loop2 (conf-set-next ender-set k)
|
||||
(+ n (* nb-prev-trees nb-ender-trees))))
|
||||
(loop2 (conf-set-next ender-set k) n))
|
||||
(loop1 (cdr l) n)))
|
||||
(loop1 (cdr l) n)))
|
||||
n)))))
|
||||
|
||||
(define (nb-deriv-trees* nt i j nts enders steps toks states)
|
||||
(let ((nt* (ind nt nts)))
|
||||
(if nt*
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
(let loop ((l (vector-ref enders nt*)) (nb-trees 0))
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(if (conf-set-member? (vector-ref states j) conf i)
|
||||
(loop (cdr l)
|
||||
(+ (nb-deriv-trees conf i j enders steps
|
||||
toks states nb-nts)
|
||||
nb-trees))
|
||||
(loop (cdr l) nb-trees)))
|
||||
nb-trees)))
|
||||
#f)))
|
||||
|
||||
(let* ((lexer (vector-ref parser-descr 0))
|
||||
(nts (vector-ref parser-descr 1))
|
||||
(starters (vector-ref parser-descr 2))
|
||||
(enders (vector-ref parser-descr 3))
|
||||
(predictors (vector-ref parser-descr 4))
|
||||
(steps (vector-ref parser-descr 5))
|
||||
(names (vector-ref parser-descr 6))
|
||||
(toks (input->tokens input lexer nts)))
|
||||
|
||||
(vector nts
|
||||
starters
|
||||
enders
|
||||
predictors
|
||||
steps
|
||||
names
|
||||
toks
|
||||
(backward (forward starters enders predictors steps nts toks)
|
||||
enders steps nts toks)
|
||||
parsed?
|
||||
deriv-trees*
|
||||
nb-deriv-trees*))))))
|
||||
|
||||
(define (parse->parsed? parse nt i j)
|
||||
(let* ((nts (vector-ref parse 0))
|
||||
(enders (vector-ref parse 2))
|
||||
(states (vector-ref parse 7))
|
||||
(parsed? (vector-ref parse 8)))
|
||||
(parsed? nt i j nts enders states)))
|
||||
|
||||
(define (parse->trees parse nt i j)
|
||||
(let* ((nts (vector-ref parse 0))
|
||||
(enders (vector-ref parse 2))
|
||||
(steps (vector-ref parse 4))
|
||||
(names (vector-ref parse 5))
|
||||
(toks (vector-ref parse 6))
|
||||
(states (vector-ref parse 7))
|
||||
(deriv-trees* (vector-ref parse 9)))
|
||||
(deriv-trees* nt i j nts enders steps names toks states)))
|
||||
|
||||
(define (parse->nb-trees parse nt i j)
|
||||
(let* ((nts (vector-ref parse 0))
|
||||
(enders (vector-ref parse 2))
|
||||
(steps (vector-ref parse 4))
|
||||
(toks (vector-ref parse 6))
|
||||
(states (vector-ref parse 7))
|
||||
(nb-deriv-trees* (vector-ref parse 10)))
|
||||
(nb-deriv-trees* nt i j nts enders steps toks states)))
|
||||
|
||||
(define (test input)
|
||||
(let ((p (make-parser '( (s (a) (s s)) )
|
||||
(lambda (l) (map (lambda (x) (list x x)) l)))))
|
||||
(let ((x (p input))
|
||||
(n (length input)))
|
||||
(length (parse->trees x 's 0 n)))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "earley"))
|
||||
(run-r6rs-benchmark
|
||||
(string-append name ":" s2)
|
||||
count
|
||||
(lambda () (test (hide count (vector->list (make-vector input1 'a)))))
|
||||
(lambda (result) (equal? result output)))))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue