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

import R6RS benchmarks from larceny (https://github.com/larceny/larceny)

This commit is contained in:
Sunrin SHIMURA (keen) 2015-01-18 04:20:54 +00:00
parent 592af901e2
commit cd94f5b554
148 changed files with 187891 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
etc/R7RS/README Normal file
View File

@ -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.

425
etc/R7RS/bench Executable file
View File

@ -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

17650
etc/R7RS/inputs/NormalizationTest.txt Normal file
View File

File diff suppressed because it is too large Load Diff

4
etc/R7RS/inputs/ack.input Normal file
View File

@ -0,0 +1,4 @@
1
3
12
32765

3
etc/R7RS/inputs/array1.input Normal file
View File

@ -0,0 +1,3 @@
100
1000000
1000000

31102
etc/R7RS/inputs/bib Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
etc/R7RS/inputs/bib16 Normal file
View File

Binary file not shown.

4
etc/R7RS/inputs/bibfreq.input Normal file
View File

@ -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))

4
etc/R7RS/inputs/bibfreq2.input Normal file
View File

@ -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))

18
etc/R7RS/inputs/browse.input Normal file
View File

@ -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)

4
etc/R7RS/inputs/bv2string.input Normal file
View File

@ -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

6
etc/R7RS/inputs/cat.input Normal file
View File

@ -0,0 +1,6 @@
25
"inputs/bib"
"outputs/cat.output"
ignored

6
etc/R7RS/inputs/cat2.input Normal file
View File

@ -0,0 +1,6 @@
25
"inputs/bib"
"outputs/cat2.output"
ignored

6
etc/R7RS/inputs/cat3.input Normal file
View File

@ -0,0 +1,6 @@
10
"inputs/bib16"
"outputs/cat3.output"
ignored

555
etc/R7RS/inputs/compiler.input Normal file
View File

@ -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:"
"")

34
etc/R7RS/inputs/conform.input Normal file
View File

@ -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")

14
etc/R7RS/inputs/cpstak.input Normal file
View File

@ -0,0 +1,14 @@
5
32
16
8
9
; The old inputs and output for cpstak were:
1700
18
12
6
7

14
etc/R7RS/inputs/ctak.input Normal file
View File

@ -0,0 +1,14 @@
1
32
16
8
9
; The old inputs and output for ctak were:
160
18
12
6
7

8
etc/R7RS/inputs/dderiv.input Normal file
View File

@ -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)

8
etc/R7RS/inputs/deriv.input Normal file
View File

@ -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)

16
etc/R7RS/inputs/destruc.input Normal file
View File

@ -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))

3
etc/R7RS/inputs/diviter.input Normal file
View File

@ -0,0 +1,3 @@
1000000
1000
500

3
etc/R7RS/inputs/divrec.input Normal file
View File

@ -0,0 +1,3 @@
1000000
1000
500

2319
etc/R7RS/inputs/dynamic.data Normal file
View File

File diff suppressed because it is too large Load Diff

3
etc/R7RS/inputs/dynamic.input Normal file
View File

@ -0,0 +1,3 @@
200
"inputs/dynamic.data"
((218 . 455) (6 . 1892) (2204 . 446))

3
etc/R7RS/inputs/earley.input Normal file
View File

@ -0,0 +1,3 @@
1
15
2674440

7
etc/R7RS/inputs/equal.input Normal file
View File

@ -0,0 +1,7 @@
100
100
8
1000
2000
5000
#t

4
etc/R7RS/inputs/fft.input Normal file
View File

@ -0,0 +1,4 @@
50
65536
0.0
0.0

3
etc/R7RS/inputs/fib.input Normal file
View File

@ -0,0 +1,3 @@
1
40
102334155

3
etc/R7RS/inputs/fibc.input Normal file
View File

@ -0,0 +1,3 @@
10
30
832040

3
etc/R7RS/inputs/fibfp.input Normal file
View File

@ -0,0 +1,3 @@
10
35.0
9227465.0

3
etc/R7RS/inputs/gcbench.input Normal file
View File

@ -0,0 +1,3 @@
1
20
0

3
etc/R7RS/inputs/graphs.input Normal file
View File

@ -0,0 +1,3 @@
1
7
213829

5
etc/R7RS/inputs/hashtable0.input Normal file
View File

@ -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)

3
etc/R7RS/inputs/lattice.input Normal file
View File

@ -0,0 +1,3 @@
10
44
120549

4
etc/R7RS/inputs/listsort.input Normal file
View File

@ -0,0 +1,4 @@
1
0
#x10ffff
ignored

14
etc/R7RS/inputs/matrix.input Normal file
View File

@ -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)))))

46
etc/R7RS/inputs/maze.input Normal file
View File

@ -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)

15
etc/R7RS/inputs/mazefun.input Normal file
View File

@ -0,0 +1,15 @@
5000
11
11
((_ * _ _ _ _ _ _ _ _ _)
(_ * * * * * * * _ * *)
(_ _ _ * _ _ _ * _ _ _)
(_ * _ * _ * _ * _ * _)
(_ * _ _ _ * _ * _ * _)
(* * _ * * * * * _ * _)
(_ * _ _ _ _ _ _ _ * _)
(_ * _ * _ * * * * * *)
(_ _ _ * _ _ _ _ _ _ _)
(_ * * * * * * * _ * *)
(_ * _ _ _ _ _ _ _ _ _))

3
etc/R7RS/inputs/mbrot.input Normal file
View File

@ -0,0 +1,3 @@
1000
75
5

3
etc/R7RS/inputs/mbrotZ.input Normal file
View File

@ -0,0 +1,3 @@
1000
75
5

35
etc/R7RS/inputs/mperm.input Normal file
View File

@ -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)

4
etc/R7RS/inputs/nboyer.input Normal file
View File

@ -0,0 +1,4 @@
1
4
16445406 ; if the input is 4
51507739 ; if the input is 5

9
etc/R7RS/inputs/normalization.input Normal file
View File

@ -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

3
etc/R7RS/inputs/nqueens.input Normal file
View File

@ -0,0 +1,3 @@
10
13
73712

21
etc/R7RS/inputs/ntakl.input Normal file
View File

@ -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

3
etc/R7RS/inputs/nucleic.input Normal file
View File

@ -0,0 +1,3 @@
50
()
33.797594890762724

10
etc/R7RS/inputs/paraffins.input Normal file
View File

@ -0,0 +1,10 @@
5
23
5731580
; the following seems to take too much memory
5
24
14490245

772
etc/R7RS/inputs/parsing.data Normal file
View File

@ -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)

3
etc/R7RS/inputs/parsing.input Normal file
View File

@ -0,0 +1,3 @@
2500
"inputs/parsing.data"
(should return this list)

BIN
etc/R7RS/inputs/parsing16.data Normal file
View File

Binary file not shown.

16
etc/R7RS/inputs/peval.input Normal file
View File

@ -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))

35
etc/R7RS/inputs/pi.input Normal file
View File

@ -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))

4
etc/R7RS/inputs/pnpoly.input Normal file
View File

@ -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

13
etc/R7RS/inputs/primes.input Normal file
View File

@ -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)

3
etc/R7RS/inputs/puzzle.input Normal file
View File

@ -0,0 +1,3 @@
500
511
2005

4
etc/R7RS/inputs/quicksort.input Normal file
View File

@ -0,0 +1,4 @@
2500
10000
1000000
ignored

4
etc/R7RS/inputs/ray.input Normal file
View File

@ -0,0 +1,4 @@
20
1
"outputs/ray.output"
ok

4
etc/R7RS/inputs/read0.input Normal file
View File

@ -0,0 +1,4 @@
1
0
#x10ffff
ignored

5
etc/R7RS/inputs/read1.input Normal file
View File

@ -0,0 +1,5 @@
2500
"inputs/parsing.data"
(should return this list)

5
etc/R7RS/inputs/read2.input Normal file
View File

@ -0,0 +1,5 @@
2500
"inputs/parsing.data"
(should return this list)

5
etc/R7RS/inputs/read3.input Normal file
View File

@ -0,0 +1,5 @@
2500
"inputs/parsing16.data"
(should return this list)

4
etc/R7RS/inputs/sboyer.input Normal file
View File

@ -0,0 +1,4 @@
1
5
51507739 ; if the input is 5
16445406 ; if the input is 4

41
etc/R7RS/inputs/scheme.input Normal file
View File

@ -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")

4
etc/R7RS/inputs/simplex.input Normal file
View File

@ -0,0 +1,4 @@
1000000
740.0
(#(4 1 3 2) #(0 5 7 6))

547
etc/R7RS/inputs/slatex-data/slatex.sty Normal file
View File

@ -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? ***}

1658
etc/R7RS/inputs/slatex-data/test.tex Normal file
View File

File diff suppressed because it is too large Load Diff

4
etc/R7RS/inputs/slatex.input Normal file
View File

@ -0,0 +1,4 @@
100
"inputs/slatex-data/test"
ignored
ignored

3
etc/R7RS/inputs/string.input Normal file
View File

@ -0,0 +1,3 @@
10
500000
524278

3
etc/R7RS/inputs/sum.input Normal file
View File

@ -0,0 +1,3 @@
100000
10000
50005000

100000
etc/R7RS/inputs/sum1.data Normal file
View File

File diff suppressed because it is too large Load Diff

3
etc/R7RS/inputs/sum1.input Normal file
View File

@ -0,0 +1,3 @@
10
"inputs/sum1.data"
15794.975

4
etc/R7RS/inputs/sumfp.input Normal file
View File

@ -0,0 +1,4 @@
250
1e6
5.000005e11

4
etc/R7RS/inputs/tail.input Normal file
View File

@ -0,0 +1,4 @@
10
"inputs/bib"
"outputs/tail.output"
ignored

14
etc/R7RS/inputs/tak.input Normal file
View File

@ -0,0 +1,14 @@
10
32
16
8
9
; The old inputs and output for tak were:
3000
18
12
6
7

21
etc/R7RS/inputs/takl.input Normal file
View File

@ -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

4
etc/R7RS/inputs/triangl.input Normal file
View File

@ -0,0 +1,4 @@
50
22
1
(22 34 31 15 7 1 20 17 25 6 5 13 32)

4
etc/R7RS/inputs/vecsort.input Normal file
View File

@ -0,0 +1,4 @@
1
0
#x10ffff
ignored

3
etc/R7RS/inputs/wc.input Normal file
View File

@ -0,0 +1,3 @@
25
"inputs/bib"
(31102 851820 4460056)

23
etc/R7RS/src/ack.sch Normal file
View File

@ -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)))))

41
etc/R7RS/src/array1.sch Normal file
View File

@ -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)))))

65
etc/R7RS/src/bibfreq.sch Normal file
View File

@ -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)))))

66
etc/R7RS/src/bibfreq2.sch Normal file
View File

@ -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)))))

207
etc/R7RS/src/browse.sch Normal file
View File

@ -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)))))

599
etc/R7RS/src/bv2string.sch Normal file
View File

@ -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)))))

39
etc/R7RS/src/cat.sch Normal file
View File

@ -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))))

42
etc/R7RS/src/cat2.sch Normal file
View File

@ -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))))

42
etc/R7RS/src/cat3.sch Normal file
View File

@ -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))))

43
etc/R7RS/src/common.sch Normal file
View File

@ -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)

11153
etc/R7RS/src/compiler.sch Normal file
View File

File diff suppressed because it is too large Load Diff

469
etc/R7RS/src/conform.sch Normal file
View File

@ -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)))))

44
etc/R7RS/src/cpstak.sch Normal file
View File

@ -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)))))

40
etc/R7RS/src/ctak.sch Normal file
View File

@ -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)))))

91
etc/R7RS/src/dderiv.sch Normal file
View File

@ -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)))))

47
etc/R7RS/src/deriv.sch Normal file
View File

@ -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)))))

63
etc/R7RS/src/destruc.sch Normal file
View File

@ -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)))))

30
etc/R7RS/src/diviter.sch Normal file
View File

@ -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)))))

29
etc/R7RS/src/divrec.sch Normal file
View File

@ -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)))))

2331
etc/R7RS/src/dynamic.sch Normal file
View File

File diff suppressed because it is too large Load Diff

662
etc/R7RS/src/earley.sch Normal file
View File

@ -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